diff --git a/.circleci/config.yml b/.circleci/config.yml index 7e2752bb..86eef77c 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -2,7 +2,7 @@ version: 2 jobs: build: docker: - - image: haskell:latest + - image: haskell:8.2.2 - image: circleci/postgres:latest environment: POSTGRES_DB: exampledb diff --git a/README.md b/README.md index 3b8e43b4..e4586c72 100644 --- a/README.md +++ b/README.md @@ -44,6 +44,8 @@ composable and cover a large portion of SQL. * linear, invertible migrations * connection pools * transactions +* views +* composite and enumerated types ## installation @@ -62,24 +64,25 @@ Let's see an example! First, we need some language extensions because Squeal uses modern GHC features. -```haskell +```Haskell >>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators ``` We'll need some imports. -```haskell +```Haskell >>> import Control.Monad (void) >>> import Control.Monad.Base (liftBase) >>> import Data.Int (Int32) >>> import Data.Text (Text) >>> import Squeal.PostgreSQL +>>> import Squeal.PostgreSQL.Render ``` We'll use generics to easily convert between Haskell and PostgreSQL values. -```haskell +```Haskell >>> import qualified Generics.SOP as SOP >>> import qualified GHC.Generics as GHC ``` @@ -87,93 +90,99 @@ We'll use generics to easily convert between Haskell and PostgreSQL values. The first step is to define the schema of our database. This is where we use `DataKinds` and `TypeOperators`. -```haskell +```Haskell >>> :{ type Schema = - '[ "users" ::: - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] - , "emails" ::: - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ] - ] + '[ "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"] "users" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ]) + ] :} ``` -Notice the use of type operators. `:::` is used -to pair an alias `Symbol` with either a `TableType` or a `ColumnType`. -`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`, +Notice the use of type operators. + +`:::` is used to pair an alias `GHC.TypeLits.Symbol` with 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 a `ColumnConstraint` with a `NullityType`, -yielding a `ColumnType`. +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` is a `createTable`, `alterTable` or `dropTable` -command and 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 +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 +```Haskell >>> :{ let setup :: Definition '[] Schema setup = - createTable #users - ( serial `As` #id :* - (text & notNull) `As` #name :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>> - createTable #emails - ( serial `As` #id :* - (int & notNull) `As` #user_id :* - text `As` #email :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_emails :* - foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) - OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) + createTable #users + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> + createTable #emails + ( serial `As` #id :* + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id + OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) :} ``` -We can easily see the generated SQL is unsuprising looking. +We can easily see the generated SQL is unsurprising looking. -```haskell ->>> renderDefinition 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, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE CASCADE ON UPDATE CASCADE);" +```Haskell +>>> 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 schema `'[]` and produces `Schema`. In our `createTable` commands we included `TableConstraint`s to define -primary and foreign keys, making them somewhat complex. Our tear down +primary and foreign keys, making them somewhat complex. Our `teardown` `Definition` is simpler. -```haskell +```Haskell >>> :{ let teardown :: Definition Schema '[] teardown = dropTable #emails >>> dropTable #users :} ->>> renderDefinition teardown -"DROP TABLE emails; DROP TABLE users;" + +>>> printSQL teardown +DROP TABLE "emails"; +DROP TABLE "users"; ``` Next, we'll write `Manipulation`s to insert data into our two tables. -A `Manipulation` is an `insertRow` (or other inserts), `update` -or `deleteFrom` command and +A `Manipulation` like `insertRow`, `update` or `deleteFrom` has three type parameters, the schema it refers to, a list of parameters it can take as input, and a list of columns it produces as output. 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 optional, we can use a default +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. Take a careful look at the type and definition of both of our inserts. -```haskell +```Haskell >>> :{ let insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ] @@ -181,6 +190,7 @@ let (Default `As` #id :* Set (param @1) `As` #name :* Nil) OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) :} + >>> :{ let insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[] @@ -190,10 +200,11 @@ let Set (param @2) `As` #email :* Nil ) OnConflictDoNothing (Returning Nil) :} ->>> renderManipulation insertUser -"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING id AS fromOnly;" ->>> renderManipulation insertEmail -"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING;" + +>>> printSQL insertUser +INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly" +>>> printSQL insertEmail +INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING ``` Next we write a `Query` to retrieve users from the database. We're not @@ -201,7 +212,7 @@ interested in the ids here, just the usernames and email addresses. We need to use an inner join to get the right result. A `Query` is like a `Manipulation` with the same kind of type parameters. -```haskell +```Haskell >>> :{ let getUsers :: Query Schema '[] @@ -213,8 +224,9 @@ let & innerJoin (table (#emails `As` #e)) (#u ! #id .== #e ! #user_id)) ) :} ->>> renderQuery 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)" + +>>> 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") ``` Now that we've defined the SQL side of things, we'll need a Haskell type @@ -223,7 +235,7 @@ for users. We give the type `Generics.SOP.Generic` and we receive when we run `getUsers`. Notice that the record fields of the `User` type match the column names of `getUsers`. -```haskell +```Haskell >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) >>> instance SOP.Generic User >>> instance SOP.HasDatatypeInfo User @@ -231,7 +243,7 @@ we receive when we run `getUsers`. Notice that the record fields of the Let's also create some users to add to the database. -```haskell +```Haskell >>> :{ let users :: [User] @@ -251,7 +263,7 @@ 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 +```Haskell >>> :{ let session :: PQ Schema Schema IO () @@ -262,12 +274,11 @@ let usersResult <- runQuery getUsers usersRows <- getRows usersResult liftBase $ print (usersRows :: [User]) -:} ->>> :{ -void . withConnection "host=localhost port=5432 dbname=exampledb" $ - define setup - & pqThen session - & pqThen (define teardown) +in + void . withConnection "host=localhost port=5432 dbname=exampledb" $ + 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"}] ``` diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index f449fe24..f28b9adc 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -1,5 +1,245 @@ ## RELEASE NOTES +### 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 algbraic 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 diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index e9a99b5c..dc3f918f 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -25,36 +25,36 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC type Schema = - '[ "users" ::: + '[ "users" ::: 'Table ( '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2) - ] - , "emails" ::: + ]) + , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"] , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 , "email" ::: 'NoDef :=> 'Null 'PGtext - ] + ]) ] setup :: Definition '[] Schema setup = createTable #users ( serial `As` #id :* - (text & notNull) `As` #name :* - (vararray int2 & notNull) `As` #vec :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) + (text & notNullable) `As` #name :* + (vararray int2 & notNullable) `As` #vec :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* - (int & notNull) `As` #user_id :* - text `As` #email :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_emails :* - foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) teardown :: Definition Schema '[] diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index b7872e78..8039d01c 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -1,5 +1,5 @@ name: squeal-postgresql -version: 0.2.1.0 +version: 0.3.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal @@ -34,11 +34,13 @@ library Squeal.PostgreSQL.Schema Squeal.PostgreSQL.Transaction default-language: Haskell2010 - ghc-options: -Wall -fprint-explicit-kinds + ghc-options: -Wall -Werror build-depends: aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 + , binary-parser >= 0.5.5 , bytestring >= 0.10.8.2 + , bytestring-strict-builder >= 0.4.5 , deepseq >= 1.4.3.0 , generics-sop >= 0.3.2.0 , lifted-base >= 0.2.3.12 @@ -61,7 +63,7 @@ test-suite squeal-postgresql-doctest default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - ghc-options: -Wall + ghc-options: -Wall -Werror main-is: DocTest.hs build-depends: base >= 4.10.0.0 @@ -70,7 +72,7 @@ test-suite squeal-postgresql-doctest executable squeal-postgresql-example default-language: Haskell2010 hs-source-dirs: exe - ghc-options: -Wall + ghc-options: -Wall -Werror main-is: Example.hs build-depends: base >= 4.10.0.0 && < 5.0 diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 1084e689..7a3d98c2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -1,206 +1,211 @@ --- | Module: Squeal.PostgreSQL --- Description: Squeel export module --- Copyright: (c) Eitan Chatav, 2017 --- 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 --- >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators --- --- We'll need some imports. --- --- >>> import Control.Monad (void) --- >>> import Control.Monad.Base (liftBase) --- >>> 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 Schema = --- '[ "users" ::: --- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ] --- , "emails" ::: --- '[ "pk_emails" ::: 'PrimaryKey '["id"] --- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] --- ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 --- , "email" ::: 'NoDef :=> 'Null 'PGtext --- ] --- ] --- :} --- --- Notice the use of type operators. `:::` is used --- to pair an alias `Symbol` with either a `TableType` or a `ColumnType`. --- `:=>` is used to pair a `TableConstraint`s with a `ColumnsType`, --- yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, --- yielding a `ColumnType`. --- --- Next, we'll write `Definition`s to set up and tear down the schema. In --- Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable` --- command and 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 '[] Schema --- setup = --- createTable #users --- ( serial `As` #id :* --- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>> --- createTable #emails --- ( serial `As` #id :* --- (int & notNull) `As` #user_id :* --- text `As` #email :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_emails :* --- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) --- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) --- :} --- --- We can easily see the generated SQL is unsuprising looking. --- --- >>> renderDefinition 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, 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 schema @'[]@ and produces @Schema@. --- In our `createTable` commands we included `TableConstraint`s to define --- primary and foreign keys, making them somewhat complex. Our tear down --- `Definition` is simpler. --- --- >>> :{ --- let --- teardown :: Definition Schema '[] --- teardown = dropTable #emails >>> dropTable #users --- :} --- --- >>> renderDefinition teardown --- "DROP TABLE \"emails\"; DROP TABLE \"users\";" --- --- Next, we'll write `Manipulation`s to insert data into our two tables. --- A `Manipulation` is an `insertRow` (or other inserts), `update` --- or `deleteFrom` command and --- has three type parameters, the schema it refers to, a list of parameters --- it can take as input, and a list of columns it produces as output. 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 optional, 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. Take a careful look at the type and definition of both --- of our inserts. --- --- >>> :{ --- let --- insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ] --- insertUser = insertRow #users --- (Default `As` #id :* Set (param @1) `As` #name :* Nil) --- OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) --- :} --- --- >>> :{ --- let --- insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[] --- insertEmail = insertRow #emails --- ( Default `As` #id :* --- Set (param @1) `As` #user_id :* --- Set (param @2) `As` #email :* Nil ) --- OnConflictDoNothing (Returning Nil) --- :} --- --- >>> renderManipulation insertUser --- "INSERT INTO \"users\" (\"id\", \"name\") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING \"id\" AS \"fromOnly\";" --- >>> renderManipulation insertEmail --- "INSERT INTO \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING;" --- --- Next we write a `Query` 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 inner join to get the right result. A `Query` is like a --- `Manipulation` with the same kind of type parameters. --- --- >>> :{ --- let --- getUsers :: Query Schema '[] --- '[ "userName" ::: 'NotNull 'PGtext --- , "userEmail" ::: 'Null 'PGtext ] --- getUsers = select --- (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil) --- ( from (table (#users `As` #u) --- & innerJoin (table (#emails `As` #e)) --- (#u ! #id .== #e ! #user_id)) ) --- :} --- --- >>> renderQuery 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\")" --- --- Now that we've defined the SQL side of things, we'll need a Haskell type --- for users. We give the type `Generics.SOP.Generic` and --- `Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows --- we receive when we run @getUsers@. Notice that the record fields of the --- @User@ type match the column names of @getUsers@. --- --- >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) --- >>> instance SOP.Generic User --- >>> instance SOP.HasDatatypeInfo User --- --- Let's also 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 Schema Schema IO () --- session = do --- idResults <- traversePrepared insertUser (Only . userName <$> users) --- ids <- traverse (fmap fromOnly . getRow 0) idResults --- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) --- usersResult <- runQuery getUsers --- usersRows <- getRows usersResult --- liftBase $ print (usersRows :: [User]) --- :} --- --- >>> :{ --- void . withConnection "host=localhost port=5432 dbname=exampledb" $ --- 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"}] +{-| +Module: Squeal.PostgreSQL +Description: Squeel export module +Copyright: (c) Eitan Chatav, 2017 +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 +>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators + +We'll need some imports. + +>>> import Control.Monad (void) +>>> import Control.Monad.Base (liftBase) +>>> import Data.Int (Int32) +>>> import Data.Text (Text) +>>> import Squeal.PostgreSQL +>>> import Squeal.PostgreSQL.Render + +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 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"] "users" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ]) + ] +:} + +Notice the use of type operators. + +`:::` is used to pair an alias `GHC.TypeLits.Symbol` with 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 a `ColumnConstraint` with a `NullityType`, +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 '[] Schema + setup = + createTable #users + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> + createTable #emails + ( serial `As` #id :* + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id + OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) +:} + +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 schema @'[]@ and produces @Schema@. +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 Schema '[] + teardown = dropTable #emails >>> dropTable #users +:} + +>>> printSQL teardown +DROP TABLE "emails"; +DROP TABLE "users"; + +Next, we'll write `Manipulation`s to insert data into our two tables. +A `Manipulation` like `insertRow`, `update` or `deleteFrom` +has three type parameters, the schema it refers to, a list of parameters +it can take as input, and a list of columns it produces as output. 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. Take a careful look at the type and definition of both +of our inserts. + +>>> :{ +let + insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ] + insertUser = insertRow #users + (Default `As` #id :* Set (param @1) `As` #name :* Nil) + OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) +:} + +>>> :{ +let + insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[] + insertEmail = insertRow #emails + ( Default `As` #id :* + Set (param @1) `As` #user_id :* + Set (param @2) `As` #email :* Nil ) + OnConflictDoNothing (Returning Nil) +:} + +>>> printSQL insertUser +INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly" +>>> printSQL insertEmail +INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING + +Next we write a `Query` 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 inner join to get the right result. A `Query` is like a +`Manipulation` with the same kind of type parameters. + +>>> :{ +let + getUsers :: Query Schema '[] + '[ "userName" ::: 'NotNull 'PGtext + , "userEmail" ::: 'Null 'PGtext ] + getUsers = select + (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil) + ( 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") + +Now that we've defined the SQL side of things, we'll need a Haskell type +for users. We give the type `Generics.SOP.Generic` and +`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows +we receive when we run @getUsers@. Notice that the record fields of the +@User@ type match the column names of @getUsers@. + +>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) +>>> instance SOP.Generic User +>>> instance SOP.HasDatatypeInfo User + +Let's also 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 Schema Schema IO () + session = do + idResults <- traversePrepared insertUser (Only . userName <$> users) + ids <- traverse (fmap fromOnly . getRow 0) idResults + traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) + usersResult <- runQuery getUsers + usersRows <- getRows usersResult + liftBase $ print (usersRows :: [User]) +in + void . withConnection "host=localhost port=5432 dbname=exampledb" $ + 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"}] +-} module Squeal.PostgreSQL ( module Squeal.PostgreSQL.Binary , module Squeal.PostgreSQL.Definition diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 4ebd8c04..c6fb1b8e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -5,13 +5,131 @@ Copyright: (c) Eitan Chatav, 2017 Maintainer: eitan@morphism.tech Stability: experimental -Binary encoding and decoding between Haskell and PostgreSQL types. +This module provides binary encoding and decoding between Haskell and PostgreSQL types. + +Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses, so you absolutely +do not need to define your own instances to decode retrieved rows into Haskell values or +to encode Haskell values into statement parameters. + +>>> import Data.Int (Int16) +>>> import Data.Text (Text) + +>>> data Row = Row { col1 :: Int16, col2 :: Text } deriving (Eq, GHC.Generic) +>>> instance Generic Row +>>> instance HasDatatypeInfo Row + +>>> import Control.Monad (void) +>>> import Control.Monad.Base (liftBase) +>>> import Squeal.PostgreSQL + +>>> :{ +let + query :: Query '[] + '[ 'NotNull 'PGint2, 'NotNull 'PGtext] + '["col1" ::: 'NotNull 'PGint2, "col2" ::: 'NotNull 'PGtext] + query = values_ (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) +:} + +>>> :{ +let + roundtrip :: IO () + roundtrip = void . withConnection "host=localhost port=5432 dbname=exampledb" $ do + result <- runQueryParams query (2 :: Int16, "hi" :: Text) + Just row <- firstRow result + liftBase . print $ row == Row 2 "hi" +:} + +>>> roundtrip +True + +In addition to being able to encode and decode basic Haskell types like `Int16` and `Text`, +Squeal permits you to encode and decode Haskell types which are equivalent to +Postgres enumerated and composite types. + +Enumerated (enum) types 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. + +>>> data Schwarma = Beef | Lamb | Chicken deriving (Show, GHC.Generic) +>>> instance Generic Schwarma +>>> instance HasDatatypeInfo Schwarma + +A composite type represents the structure of a row or record; +it is essentially just a list of field names and their data types. They 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. + +>>> data Person = Person {name :: Maybe Text, age :: Maybe Int32} deriving (Show, GHC.Generic) +>>> instance Generic Person +>>> instance HasDatatypeInfo Person + +We can create the equivalent Postgres types directly from their Haskell types. + +>>> :{ +type Schema = + '[ "schwarma" ::: 'Typedef (EnumFrom Schwarma) + , "person" ::: 'Typedef (CompositeFrom Person) + ] +:} + +>>> :{ +let + setup :: Definition '[] Schema + setup = + createTypeEnumFrom @Schwarma #schwarma >>> + createTypeCompositeFrom @Person #person +:} + +Then we can perform roundtrip queries; + +>>> :{ +let + querySchwarma :: Query Schema + '[ 'NotNull (EnumFrom Schwarma)] + '["fromOnly" ::: 'NotNull (EnumFrom Schwarma)] + querySchwarma = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil) +:} + +>>> :{ +let + queryPerson :: Query Schema + '[ 'NotNull (CompositeFrom Person)] + '["fromOnly" ::: 'NotNull (CompositeFrom Person)] + queryPerson = values_ (parameter @1 #person `As` #fromOnly :* Nil) +:} + +And finally drop the types. + +>>> :{ +let + teardown :: Definition Schema '[] + teardown = dropType #schwarma >>> dropType #person +:} + +Now let's run it. + +>>> :{ +let + session = do + result1 <- runQueryParams querySchwarma (Only Chicken) + Just (Only schwarma) <- firstRow result1 + liftBase $ print (schwarma :: Schwarma) + result2 <- runQueryParams queryPerson (Only (Person (Just "Faisal") (Just 24))) + Just (Only person) <- firstRow result2 + liftBase $ print (person :: Person) +in + void . withConnection "host=localhost port=5432 dbname=exampledb" $ + define setup + & pqThen session + & pqThen (define teardown) +:} +Chicken +Person {name = Just "Faisal", age = Just 24} -} {-# LANGUAGE - ConstraintKinds - , DataKinds - , DefaultSignatures + AllowAmbiguousTypes , DeriveFoldable , DeriveFunctor , DeriveGeneric @@ -20,11 +138,9 @@ Binary encoding and decoding between Haskell and PostgreSQL types. , FlexibleInstances , GADTs , LambdaCase - , KindSignatures , MultiParamTypeClasses , ScopedTypeVariables , TypeApplications - , TypeFamilies , TypeInType , TypeOperators , UndecidableInstances @@ -43,9 +159,12 @@ module Squeal.PostgreSQL.Binary , Only (..) ) where +import BinaryParser +import ByteString.StrictBuilder import Data.Aeson hiding (Null) import Data.Int import Data.Kind +import Data.Monoid hiding (All) import Data.Scientific import Data.Time import Data.UUID.Types @@ -56,7 +175,7 @@ import GHC.TypeLits import Network.IP.Addr import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString as Strict hiding (unpack) +import qualified Data.ByteString as Strict hiding (pack, unpack) import qualified Data.Text.Lazy as Lazy import qualified Data.Text as Strict import qualified Data.Vector as Vector @@ -119,9 +238,83 @@ instance (HasOid pg, ToParam x pg) => ToParam (Vector (Maybe x)) ('PGvararray pg) where toParam = K . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg) +instance + ( IsEnumType x + , HasDatatypeInfo x + , LabelsFrom x ~ labels + ) => ToParam x ('PGenum labels) where + toParam = + let + gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String + gshowConstructor Nil _ = "" + gshowConstructor (constructor :* _) (SOP (Z _)) = + constructorName constructor + gshowConstructor (_ :* constructors) (SOP (S xs)) = + gshowConstructor constructors (SOP xs) + in + K . Encoding.text_strict + . Strict.pack + . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x))) + . from +instance + ( SListI fields + , MapMaybes xs + , IsProductType x (Maybes xs) + , AllZip ToAliasedParam xs fields + , FieldNamesFrom x ~ AliasesOf fields + , All HasAliasedOid fields + ) => ToParam x ('PGcomposite fields) where + toParam = + let + + encoders = htrans (Proxy @ToAliasedParam) toAliasedParam + + composite + :: All HasAliasedOid row + => NP (K (Maybe Encoding.Encoding)) row + -> K Encoding.Encoding ('PGcomposite row) + composite fields = K $ + -- + -- [for each field] + -- + -- [if value is NULL] + -- <-1: 4 bytes> + -- [else] + -- + -- bytes> + -- [end if] + -- [end for] + int32BE (fromIntegral (lengthSList (Proxy @xs))) <> + let + each + :: HasAliasedOid field + => K (Maybe Encoding.Encoding) field + -> Encoding.Encoding + each (K field :: K (Maybe Encoding.Encoding) field) = + word32BE (aliasedOid @field) + <> case field of + Nothing -> int64BE (-1) + Just value -> + int32BE (fromIntegral (builderLength value)) + <> value + in + hcfoldMap (Proxy @HasAliasedOid) each fields + + in + composite . encoders . unMaybes . unZ . unSOP . from --- | A `ToColumnParam` constraint lifts the `ToParam` encoding --- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should +class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32 +instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty + +class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where + toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field +instance ToParam x ty => ToAliasedParam x (alias ::: ty) where + toAliasedParam = \case + Nothing -> K Nothing + Just x -> K . Just . unK $ toParam @x @ty x + +-- | A `ToColumnParam` constraint lifts the `ToParam` encoding +-- of a `Type` to a `NullityType`, encoding `Maybe`s to `Null`s. You should -- not define instances of `ToColumnParam`, just use the provided instances. class ToColumnParam (x :: Type) (ty :: NullityType) where -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0 @@ -201,9 +394,74 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where fromValue _ = Decoding.array (Decoding.dimensionArray Vector.replicateM (Decoding.nullableValueArray (fromValue (Proxy @pg)))) +instance + ( IsEnumType y + , HasDatatypeInfo y + , LabelsFrom y ~ labels + ) => FromValue ('PGenum labels) y where + fromValue _ = + let + greadConstructor + :: All ((~) '[]) xss + => NP ConstructorInfo xss + -> String + -> Maybe (SOP I xss) + greadConstructor Nil _ = Nothing + greadConstructor (constructor :* constructors) name = + if name == constructorName constructor + then Just (SOP (Z Nil)) + else SOP . S . unSOP <$> greadConstructor constructors name + in + Decoding.enum + $ fmap to + . greadConstructor (constructorInfo (datatypeInfo (Proxy @y))) + . Strict.unpack + +instance + ( SListI fields + , MapMaybes ys + , IsProductType y (Maybes ys) + , AllZip FromAliasedValue fields ys + , FieldNamesFrom y ~ AliasesOf fields + ) => FromValue ('PGcomposite fields) y where + fromValue = + let + decoders + :: forall pgs zs proxy + . AllZip FromAliasedValue pgs zs + => proxy ('PGcomposite pgs) + -> NP Decoding.Value zs + decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue + (hpure Proxy :: NP Proxy pgs) + + composite fields = do + -- + -- [for each field] + -- + -- [if value is NULL] + -- <-1: 4 bytes> + -- [else] + -- + -- bytes> + -- [end if] + -- [end for] + unitOfSize 4 + let + each field = do + unitOfSize 4 + len <- sized 4 Decoding.int + if len == -1 then return Nothing else Just <$> sized len field + htraverse' each fields + + in fmap (to . SOP . Z . maybes) . composite . decoders + +class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where + fromAliasedValue :: proxy pg -> Decoding.Value y +instance FromValue pg y => FromAliasedValue (alias ::: pg) y where + fromAliasedValue _ = fromValue (Proxy @pg) -- | A `FromColumnValue` constraint lifts the `FromValue` parser --- to a decoding of a @(Symbol, ColumnType)@ to a `Type`, +-- to a decoding of a @(Symbol, NullityType)@ to a `Type`, -- decoding `Null`s to `Maybe`s. You should not define instances for -- `FromColumnValue`, just use the provided instances. class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where @@ -220,10 +478,10 @@ instance FromValue pg y => FromColumnValue (column ::: ('NotNull pg)) y where fromColumnValue = \case K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL" - K (Just bytes) -> + K (Just bs) -> let errOrValue = - Decoding.valueParser (fromValue @pg @y Proxy) bytes + Decoding.valueParser (fromValue @pg @y Proxy) bs err str = error $ "fromColumnValue: " ++ Strict.unpack str in either err id errOrValue @@ -257,7 +515,7 @@ instance ( SListI results , IsProductType y ys , AllZip FromColumnValue results ys - , SameFields (DatatypeInfoOf y) results + , FieldNamesFrom y ~ AliasesOf results ) => FromRow results y where fromRow = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index ef7ab601..5393cda7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -9,35 +9,33 @@ Squeal data definition language. -} {-# LANGUAGE - ConstraintKinds - , DataKinds - , DeriveDataTypeable + AllowAmbiguousTypes + , ConstraintKinds , DeriveGeneric , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving - , KindSignatures , LambdaCase , MultiParamTypeClasses , OverloadedStrings , RankNTypes , ScopedTypeVariables - , StandaloneDeriving , TypeApplications , TypeInType , TypeOperators + , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Definition - ( -- * Definition + ( -- * Definition Definition (UnsafeDefinition, renderDefinition) , (>>>) - -- * Create + -- * Tables + -- ** Create , createTable , createTableIfNotExists , TableConstraintExpression (..) - , Column (..) , check , unique , primaryKey @@ -47,9 +45,9 @@ module Squeal.PostgreSQL.Definition , renderOnDeleteClause , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade) , renderOnUpdateClause - -- * Drop + -- ** Drop , dropTable - -- * Alter + -- ** Alter , alterTable , alterTableRename , AlterTable (UnsafeAlterTable, renderAlterTable) @@ -65,6 +63,26 @@ module Squeal.PostgreSQL.Definition , setNotNull , dropNotNull , alterType + -- * Views + , createView + , dropView + -- * Types + , createTypeEnum + , createTypeEnumFrom + , createTypeComposite + , createTypeCompositeFrom + , dropType + -- * Columns + , ColumnTypeExpression (..) + , nullable + , notNullable + , default_ + , serial2 + , smallserial + , serial4 + , serial + , serial8 + , bigserial ) where import Control.Category @@ -78,6 +96,7 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Schema @@ -89,67 +108,76 @@ statements -- database, like a `createTable`, `dropTable`, or `alterTable` command. -- `Definition`s may be composed using the `>>>` operator. newtype Definition - (schema0 :: TablesType) - (schema1 :: TablesType) + (schema0 :: SchemaType) + (schema1 :: SchemaType) = UnsafeDefinition { renderDefinition :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Definition schema0 schema1) where + renderSQL = renderDefinition + instance Category Definition where id = UnsafeDefinition ";" ddl1 . ddl0 = UnsafeDefinition $ - renderDefinition ddl0 <+> renderDefinition ddl1 + renderDefinition ddl0 <> "\n" <> renderDefinition ddl1 {----------------------------------------- CREATE statements -----------------------------------------} --- | `createTable` adds a table to the schema. --- --- >>> :set -XOverloadedLabels --- >>> :{ --- renderDefinition $ --- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil --- :} --- "CREATE TABLE \"tab\" (\"a\" int, \"b\" real);" +{- | `createTable` adds a table to the schema. + +>>> :set -XOverloadedLabels +>>> :{ +printSQL $ + createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil +:} +CREATE TABLE "tab" ("a" int NULL, "b" real NULL); +-} createTable :: ( KnownSymbol table , columns ~ (col ': cols) , SOP.SListI columns - , SOP.SListI constraints ) + , SOP.SListI constraints + , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 ) => Alias table -- ^ the name of the table to add - -> NP (Aliased TypeExpression) columns + -> NP (Aliased (ColumnTypeExpression schema0)) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema columns)) constraints + -> NP (Aliased (TableConstraintExpression schema1 table)) constraints -- ^ constraints that must hold for the table - -> Definition schema (Create table (constraints :=> columns) schema) -createTable table columns constraints = UnsafeDefinition $ - "CREATE TABLE" <+> renderCreation table 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 `Category` `Definition`. --- --- >>> :set -XOverloadedLabels -XTypeApplications --- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] --- >>> type Schema = '["tab" ::: Table] --- >>> :{ --- renderDefinition --- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema) --- :} --- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int, \"b\" real);" + -> Definition schema0 schema1 +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 `Category` of `Definition`s. + +>>> :set -XOverloadedLabels -XTypeApplications +>>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] +>>> type Schema = '["tab" ::: 'Table Table] +>>> :{ +let + setup :: Definition Schema Schema + setup = createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil +in printSQL setup +:} +CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); +-} createTableIfNotExists - :: ( Has table schema (constraints :=> columns) + :: ( Has table schema ('Table (constraints :=> columns)) , SOP.SListI columns , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add - -> NP (Aliased TypeExpression) columns + -> NP (Aliased (ColumnTypeExpression schema)) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema columns)) constraints + -> NP (Aliased (TableConstraintExpression schema table)) constraints -- ^ constraints that must hold for the table -> Definition schema schema -createTableIfNotExists table columns constraints = UnsafeDefinition $ +createTableIfNotExists tab columns constraints = UnsafeDefinition $ "CREATE TABLE IF NOT EXISTS" - <+> renderCreation table columns constraints + <+> renderCreation tab columns constraints -- helper function for `createTable` and `createTableIfNotExists` renderCreation @@ -157,12 +185,12 @@ renderCreation , SOP.SListI columns , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add - -> NP (Aliased TypeExpression) columns + -> NP (Aliased (ColumnTypeExpression schema0)) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema columns)) constraints + -> NP (Aliased (TableConstraintExpression schema1 table)) constraints -- ^ constraints that must hold for the table -> ByteString -renderCreation table columns constraints = renderAlias table +renderCreation tab columns constraints = renderAlias tab <+> parenthesized ( renderCommaSeparated renderColumnDef columns <> ( case constraints of @@ -171,9 +199,9 @@ renderCreation table columns constraints = renderAlias table renderCommaSeparated renderConstraint constraints ) ) <> ";" where - renderColumnDef :: Aliased TypeExpression x -> ByteString + renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString renderColumnDef (ty `As` column) = - renderAlias column <+> renderTypeExpression ty + renderAlias column <+> renderColumnTypeExpression ty renderConstraint :: Aliased (TableConstraintExpression schema columns) constraint -> ByteString @@ -193,156 +221,226 @@ renderCreation table columns constraints = renderAlias table -- violate a constraint, an error is raised. This applies -- even if the value came from the default value definition. newtype TableConstraintExpression - (schema :: TablesType) - (columns :: ColumnsType) + (schema :: SchemaType) + (table :: Symbol) (tableConstraint :: TableConstraint) = UnsafeTableConstraintExpression { renderTableConstraintExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) --- | @Column columns column@ is a witness that `column` is in `columns`. -data Column - (columns :: ColumnsType) - (column :: (Symbol,ColumnType)) - where - Column - :: Has column columns ty - => Alias column - -> Column columns (column ::: ty) - --- | Render a `Column`. -renderColumn :: Column columns column -> ByteString -renderColumn (Column column) = renderAlias column - --- | 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. --- --- >>> :{ --- renderDefinition $ --- createTable #tab --- ( (int & notNull) `As` #a :* --- (int & notNull) `As` #b :* Nil ) --- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) --- :} --- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));" +{-| 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 '[] Schema + definition = createTable #tab + ( (int & notNullable) `As` #a :* + (int & notNullable) `As` #b :* Nil ) + ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) +:} + +>>> printSQL definition +CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); +-} check - :: NP (Column columns) subcolumns - -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[] - -- ^ condition to check - -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns)) + :: ( Has alias schema ('Table table) + , HasAll aliases (TableToRelation table) subcolumns ) + => NP Alias aliases + -- ^ specify the subcolumns which are getting checked + -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[]) + -- ^ a closed `Condition` on those subcolumns + -> TableConstraintExpression schema alias ('Check aliases) check _cols condition = UnsafeTableConstraintExpression $ "CHECK" <+> parenthesized (renderExpression 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. --- --- >>> :{ --- renderDefinition $ --- createTable #tab --- ( int `As` #a :* --- int `As` #b :* Nil ) --- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil ) --- :} --- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" +{-| 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 '[] Schema + definition = createTable #tab + ( (int & nullable) `As` #a :* + (int & nullable) `As` #b :* Nil ) + ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) +:} + +>>> printSQL definition +CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); +-} unique - :: SOP.SListI subcolumns - => NP (Column columns) subcolumns - -- ^ unique column or group of columns - -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns)) + :: ( Has alias schema ('Table table) + , HasAll aliases (TableToRelation table) subcolumns ) + => NP Alias aliases + -- ^ specify subcolumns which together are unique for each row + -> TableConstraintExpression schema alias ('Unique aliases) unique columns = UnsafeTableConstraintExpression $ - "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn 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. --- --- >>> :{ --- renderDefinition $ --- createTable #tab --- ( serial `As` #id :* --- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil ) --- :} --- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));" + "UNIQUE" <+> parenthesized (commaSeparated (renderAliases 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 '[] Schema + definition = createTable #tab + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_id :* Nil ) +:} + +>>> printSQL definition +CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); +-} primaryKey - :: (SOP.SListI subcolumns, AllNotNull subcolumns) - => NP (Column columns) subcolumns - -- ^ identifying column or group of columns - -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns)) + :: ( Has alias schema ('Table table) + , HasAll aliases (TableToColumns table) subcolumns + , AllNotNull subcolumns ) + => NP Alias aliases + -- ^ specify the subcolumns which together form a primary key. + -> TableConstraintExpression schema alias ('PrimaryKey aliases) primaryKey columns = UnsafeTableConstraintExpression $ - "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn 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" ::: --- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ] --- , "emails" ::: --- '[ "pk_emails" ::: 'PrimaryKey '["id"] --- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] --- ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 --- , "email" ::: 'NoDef :=> 'Null 'PGtext --- ] --- ] --- :} --- --- >>> :{ --- let --- setup :: Definition '[] Schema --- setup = --- createTable #users --- ( serial `As` #id :* --- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>> --- createTable #emails --- ( serial `As` #id :* --- (int & notNull) `As` #user_id :* --- text `As` #email :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_emails :* --- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) --- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) --- in renderDefinition 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, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" + "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases 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"] "users" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ]) + ] +:} + +>>> :{ +let + setup :: Definition '[] Schema + setup = + createTable #users + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> + createTable #emails + ( serial `As` #id :* + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id + OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) +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"] "employees" '["id"] + ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + , "employer_id" ::: 'NoDef :=> 'Null 'PGint4 + ]) + ] +:} + +>>> :{ +let + setup :: Definition '[] Schema + setup = + createTable #employees + ( serial `As` #id :* + (text & notNullable) `As` #name :* + (integer & nullable) `As` #employer_id :* Nil ) + ( primaryKey #id `As` #employees_pk :* + foreignKey #employer_id #employees #id + OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) +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 schema table reftable subcolumns refsubcolumns - => NP (Column columns) subcolumns + :: (ForeignKeyed schema child parent + table reftable + columns refcolumns + constraints cols + reftys tys ) + => NP Alias columns -- ^ column or columns in the table - -> Alias table + -> Alias parent -- ^ reference table - -> NP (Column (TableToColumns reftable)) refsubcolumns + -> 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 schema columns - ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns)) -foreignKey columns reftable refcolumns onDelete onUpdate = - UnsafeTableConstraintExpression $ - "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns) - <+> "REFERENCES" <+> renderAlias reftable - <+> parenthesized (renderCommaSeparated renderColumn refcolumns) - <+> renderOnDeleteClause onDelete - <+> renderOnUpdateClause onUpdate - --- | A type synonym for constraints on a table with a foreign key. -type ForeignKeyed schema table reftable subcolumns refsubcolumns - = ( Has table schema reftable - , SameTypes subcolumns refsubcolumns - , AllNotNull subcolumns - , SOP.SListI subcolumns - , SOP.SListI refsubcolumns ) + -> TableConstraintExpression schema child + ('ForeignKey columns parent refcolumns) +foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ + "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys)) + <+> "REFERENCES" <+> renderAlias parent + <+> parenthesized (commaSeparated (renderAliases refs)) + <+> renderOnDeleteClause ondel + <+> renderOnUpdateClause onupd + +-- | A constraint synonym between types involved in a foreign key constraint. +type ForeignKeyed schema + child parent + table reftable + columns refcolumns + constraints cols + reftys tys = + ( Has child schema ('Table table) + , Has parent schema ('Table reftable) + , 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. data OnDeleteClause @@ -389,13 +487,19 @@ DROP statements -- | `dropTable` removes a table from the schema. -- --- >>> renderDefinition $ dropTable #muh_table --- "DROP TABLE \"muh_table\";" +-- >>> :{ +-- let +-- definition :: Definition '["muh_table" ::: 'Table t] '[] +-- definition = dropTable #muh_table +-- :} +-- +-- >>> printSQL definition +-- DROP TABLE "muh_table"; dropTable - :: KnownSymbol table + :: Has table schema ('Table t) => Alias table -- ^ table to remove -> Definition schema (Drop table schema) -dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";" +dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";" {----------------------------------------- ALTER statements @@ -403,20 +507,20 @@ ALTER statements -- | `alterTable` changes the definition of a table from the schema. alterTable - :: Has tab schema table0 - => Alias tab -- ^ table to alter - -> AlterTable schema table0 table1 -- ^ alteration to perform - -> Definition schema (Alter tab schema table1) -alterTable table alteration = UnsafeDefinition $ + :: KnownSymbol alias + => Alias alias -- ^ table to alter + -> AlterTable alias table schema -- ^ alteration to perform + -> Definition schema (Alter alias ('Table table) schema) +alterTable tab alteration = UnsafeDefinition $ "ALTER TABLE" - <+> renderAlias table + <+> renderAlias tab <+> renderAlterTable alteration <> ";" -- | `alterTableRename` changes the name of a table from the schema. -- --- >>> renderDefinition $ alterTableRename #foo #bar --- "ALTER TABLE \"foo\" RENAME TO \"bar\";" +-- >>> printSQL $ alterTableRename #foo #bar +-- ALTER TABLE "foo" RENAME TO "bar"; alterTableRename :: (KnownSymbol table0, KnownSymbol table1) => Alias table0 -- ^ table to rename @@ -429,9 +533,9 @@ alterTableRename table0 table1 = UnsafeDefinition $ -- | An `AlterTable` describes the alteration to perform on the columns -- of a table. newtype AlterTable - (schema :: TablesType) - (table0 :: TableType) - (table1 :: TableType) = + (alias :: Symbol) + (table :: TableType) + (schema :: SchemaType) = UnsafeAlterTable {renderAlterTable :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -440,19 +544,21 @@ newtype AlterTable -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0))) --- in renderDefinition definition +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0))) +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));" +-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0)); addConstraint - :: KnownSymbol alias + :: ( KnownSymbol alias + , Has tab schema ('Table table0) + , table0 ~ (constraints :=> columns) + , table1 ~ (Create alias constraint constraints :=> columns) ) => Alias alias - -> TableConstraintExpression schema columns constraint + -> TableConstraintExpression schema tab constraint -- ^ constraint to add - -> AlterTable schema (constraints :=> columns) - (Create alias constraint constraints :=> columns) + -> AlterTable tab table1 schema addConstraint alias constraint = UnsafeAlterTable $ "ADD" <+> "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint @@ -462,19 +568,20 @@ addConstraint alias constraint = UnsafeAlterTable $ -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] +-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (dropConstraint #positive) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";" +-- ALTER TABLE "tab" DROP CONSTRAINT "positive"; dropConstraint - :: KnownSymbol constraint + :: ( KnownSymbol constraint + , Has tab schema ('Table table0) + , table0 ~ (constraints :=> columns) + , table1 ~ (Drop constraint constraints :=> columns) ) => Alias constraint -- ^ constraint to drop - -> AlterTable schema - (constraints :=> columns) - (Drop constraint constraints :=> columns) + -> AlterTable tab table1 schema dropConstraint constraint = UnsafeAlterTable $ "DROP" <+> "CONSTRAINT" <+> renderAlias constraint @@ -486,34 +593,36 @@ class AddColumn ty where -- >>> :{ -- let -- definition :: Definition - -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] - -- '["tab" ::: '[] :=> + -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] + -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'Def :=> 'Null 'PGtext ]] - -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo")) - -- in renderDefinition definition + -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] + -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) + -- in printSQL definition -- :} - -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text DEFAULT E'foo';" + -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo'; -- -- >>> :{ -- let -- definition :: Definition - -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] - -- '["tab" ::: '[] :=> + -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] + -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]] - -- definition = alterTable #tab (addColumn #col2 text) - -- in renderDefinition definition + -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] + -- definition = alterTable #tab (addColumn #col2 (text & nullable)) + -- in printSQL definition -- :} - -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;" + -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; addColumn - :: KnownSymbol column + :: ( KnownSymbol column + , Has tab schema ('Table table0) + , table0 ~ (constraints :=> columns) + , table1 ~ (constraints :=> Create column ty columns) ) => Alias column -- ^ column to add - -> TypeExpression ty -- ^ type of the new column - -> AlterTable schema (constraints :=> columns) - (constraints :=> Create column ty columns) + -> ColumnTypeExpression schema ty -- ^ type of the new column + -> AlterTable tab table1 schema addColumn column ty = UnsafeAlterTable $ - "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty + "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) @@ -525,20 +634,21 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> +-- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 --- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]] --- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] +-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] +-- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (dropColumn #col2) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";" +-- ALTER TABLE "tab" DROP COLUMN "col2"; dropColumn - :: KnownSymbol column + :: ( KnownSymbol column + , Has tab schema ('Table table0) + , table0 ~ (constraints :=> columns) + , table1 ~ (constraints :=> Drop column columns) ) => Alias column -- ^ column to remove - -> AlterTable schema - (constraints :=> columns) - (DropIfConstraintsInvolve column constraints :=> Drop column columns) + -> AlterTable tab table1 schema dropColumn column = UnsafeAlterTable $ "DROP COLUMN" <+> renderAlias column @@ -547,33 +657,39 @@ dropColumn column = UnsafeAlterTable $ -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (renameColumn #foo #bar) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" RENAME COLUMN \"foo\" TO \"bar\";" +-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar"; renameColumn - :: (KnownSymbol column0, KnownSymbol column1) + :: ( KnownSymbol column0 + , KnownSymbol column1 + , Has tab schema ('Table table0) + , table0 ~ (constraints :=> columns) + , table1 ~ (constraints :=> Rename column0 column1 columns) ) => Alias column0 -- ^ column to rename -> Alias column1 -- ^ what to rename the column - -> AlterTable schema (constraints :=> columns) - (constraints :=> Rename column0 column1 columns) + -> AlterTable tab table1 schema renameColumn column0 column1 = UnsafeAlterTable $ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1 -- | An `alterColumn` alters a single column. alterColumn - :: (KnownSymbol column, Has column columns ty0) + :: ( KnownSymbol column + , Has tab schema ('Table table0) + , table0 ~ (constraints :=> columns) + , Has column columns ty0 + , tables1 ~ (constraints :=> Alter column ty1 columns)) => Alias column -- ^ column to alter - -> AlterColumn ty0 ty1 -- ^ alteration to perform - -> AlterTable schema (constraints :=> columns) - (constraints :=> Alter column columns ty1) + -> AlterColumn schema ty0 ty1 -- ^ alteration to perform + -> AlterTable tab table1 schema alterColumn column alteration = UnsafeAlterTable $ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration -- | An `AlterColumn` describes the alteration to perform on a single column. -newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) = +newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) = UnsafeAlterColumn {renderAlterColumn :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -584,15 +700,15 @@ newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) = -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col (setDefault 5)) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET DEFAULT 5;" +-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5; setDefault - :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set - -> AlterColumn (constraint :=> ty) ('Def :=> ty) + :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set + -> AlterColumn schema (constraint :=> ty) ('Def :=> ty) setDefault expression = UnsafeAlterColumn $ "SET DEFAULT" <+> renderExpression expression @@ -601,13 +717,13 @@ setDefault expression = UnsafeAlterColumn $ -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropDefault) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP DEFAULT;" -dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty) +-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT; +dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty) dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- | A `setNotNull` adds a @NOT NULL@ constraint to a column. @@ -617,14 +733,14 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (alterColumn #col setNotNull) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET NOT NULL;" +-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; setNotNull - :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) + :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- | A `dropNotNull` drops a @NOT NULL@ constraint from a column. @@ -632,14 +748,14 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropNotNull) --- in renderDefinition definition +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP NOT NULL;" +-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; dropNotNull - :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) + :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- | An `alterType` converts a column to a different data type. @@ -649,12 +765,188 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])] -- definition = --- alterTable #tab (alterColumn #col (alterType (numeric & notNull))) --- in renderDefinition definition +-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) +-- in printSQL definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;" -alterType :: TypeExpression ty -> AlterColumn ty0 ty -alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty +-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL; +alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty +alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty + +-- | Create a view. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])] +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) +-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] +-- 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"; +createView + :: KnownSymbol view + => Alias view -- ^ the name of the view to add + -> Query schema '[] relation + -- ^ query + -> Definition schema (Create view ('View relation) schema) +createView alias query = UnsafeDefinition $ + "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS" + <+> renderQuery query <> ";" + +-- | Drop a view. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) +-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] +-- '[ "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 view schema ('View v) + => Alias view -- ^ view to remove + -> Definition schema (Drop view schema) +dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" + +-- | Enumerated types are created using the `createTypeEnum` command, for example +-- +-- >>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); +createTypeEnum + :: (KnownSymbol enum, SOP.All KnownSymbol labels) + => Alias enum + -- ^ name of the user defined enumerated type + -> NP PGlabel labels + -- ^ labels of the enumerated type + -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) +createTypeEnum enum labels = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+> + parenthesized (commaSeparated (renderLabels 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 +-- >>> printSQL $ createTypeEnumFrom @Schwarma #schwarma +-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); +createTypeEnumFrom + :: forall hask enum schema. + ( SOP.Generic hask + , SOP.All KnownSymbol (LabelsFrom hask) + , KnownSymbol enum + ) + => Alias enum + -- ^ name of the user defined enumerated type + -> Definition schema (Create enum ('Typedef (EnumFrom hask)) schema) +createTypeEnumFrom enum = createTypeEnum enum + (SOP.hpure label :: NP PGlabel (LabelsFrom hask)) + +-- | `createTypeComposite` creates a composite type. The composite type is +-- specified by a list of attribute names and data types. +-- +-- >>> printSQL $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) +-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); +createTypeComposite + :: (KnownSymbol ty, SOP.SListI fields) + => Alias ty + -- ^ name of the user defined composite type + -> NP (Aliased (TypeExpression schema)) fields + -- ^ list of attribute names and data types + -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema) +createTypeComposite ty fields = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized + (renderCommaSeparated renderField fields) <> ";" + where + renderField :: Aliased (TypeExpression schema) x -> ByteString + renderField (typ `As` field) = + renderAlias field <+> renderTypeExpression typ + +-- | Composite types can also be generated from a Haskell type, for example +-- +-- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic +-- >>> instance SOP.Generic Complex +-- >>> instance SOP.HasDatatypeInfo Complex +-- >>> printSQL $ createTypeCompositeFrom @Complex #complex +-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); +createTypeCompositeFrom + :: forall hask ty schema. + ( ZipAliased (FieldNamesFrom hask) (FieldTypesFrom hask) + , SOP.All (PGTyped schema) (FieldTypesFrom hask) + , KnownSymbol ty + ) + => Alias ty + -- ^ name of the user defined composite type + -> Definition schema (Create ty ( 'Typedef (CompositeFrom hask)) schema) +createTypeCompositeFrom ty = createTypeComposite ty $ zipAs + (SOP.hpure Alias :: NP Alias (FieldNamesFrom hask)) + (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype + :: NP (TypeExpression schema) (FieldTypesFrom hask)) + +-- | Drop a type. +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance SOP.Generic Schwarma +-- >>> instance SOP.HasDatatypeInfo Schwarma +-- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] '[]) +-- DROP TYPE "schwarma"; +dropType + :: Has tydef schema ('Typedef ty) + => Alias tydef + -- ^ name of the user defined type + -> Definition schema (Drop tydef schema) +dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";" + +-- | `ColumnTypeExpression`s are used in `createTable` commands. +newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType) + = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } + deriving (GHC.Generic,Show,Eq,Ord,NFData) + +-- | used in `createTable` commands as a column constraint to note that +-- @NULL@ may be present in a column +nullable + :: TypeExpression schema ty + -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) +nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" + +-- | used in `createTable` commands as a column constraint to ensure +-- @NULL@ is not present in a column +notNullable + :: TypeExpression schema ty + -> ColumnTypeExpression schema (def :=> 'NotNull ty) +notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" + +-- | used in `createTable` commands as a column constraint to give a default +default_ + :: Expression schema '[] 'Ungrouped '[] ty + -> ColumnTypeExpression schema ('NoDef :=> ty) + -> ColumnTypeExpression schema ('Def :=> ty) +default_ x ty = UnsafeColumnTypeExpression $ + renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x + +-- | not a true type, but merely a notational convenience for creating +-- unique identifier columns with type `PGint2` +serial2, smallserial + :: ColumnTypeExpression schema ('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 schema ('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 schema ('Def :=> 'NotNull 'PGint8) +serial8 = UnsafeColumnTypeExpression "serial8" +bigserial = UnsafeColumnTypeExpression "bigserial" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index ba1c2ce6..6d193e34 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -11,21 +11,15 @@ Squeal expressions are the atoms used to build statements. {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE AllowAmbiguousTypes - , DataKinds , DeriveGeneric - , DeriveDataTypeable , FlexibleContexts , FlexibleInstances , FunctionalDependencies - , GADTs , GeneralizedNewtypeDeriving , LambdaCase , MagicHash , OverloadedStrings - , PolyKinds - , RankNTypes , ScopedTypeVariables - , StandaloneDeriving , TypeApplications , TypeFamilies , TypeInType @@ -33,21 +27,23 @@ Squeal expressions are the atoms used to build statements. , UndecidableInstances #-} -module Squeal.PostgreSQL.Expression +module Squeal.PostgreSQL.Expression ( -- * Expression Expression (UnsafeExpression, renderExpression) - , HasParameter (param) + , HasParameter (parameter) + , param -- ** Null , null_ - , unNull + , notNull , coalesce , fromNull , isNull - , isn'tNull + , isNotNull , matchNull , nullIf - -- ** Arrays + -- ** Collections , array + , row -- ** Functions , unsafeBinaryOp , unsafeUnaryOp @@ -97,8 +93,6 @@ module Squeal.PostgreSQL.Expression , count, countDistinct , every, everyDistinct , max_, maxDistinct, min_, minDistinct - -- * Tables - , Table (UnsafeTable, renderTable) -- * Types , TypeExpression (UnsafeTypeExpression, renderTypeExpression) , PGTyped (pgtype) @@ -115,12 +109,6 @@ module Squeal.PostgreSQL.Expression , real , float8 , doublePrecision - , serial2 - , smallserial - , serial4 - , serial - , serial8 - , bigserial , text , char , character @@ -139,8 +127,6 @@ module Squeal.PostgreSQL.Expression , jsonb , vararray , fixarray - , notNull - , default_ -- * Re-export , (&) , NP ((:*), Nil) @@ -150,7 +136,7 @@ import Control.Category import Control.DeepSeq import Data.ByteString (ByteString) import Data.Function ((&)) -import Data.Monoid hiding (All) +import Data.Semigroup import Data.Ratio import Data.String import Generics.SOP hiding (from) @@ -178,6 +164,7 @@ values from primitive expression using arithmetic, logical, and other operations. -} newtype Expression + (schema :: SchemaType) (relations :: RelationsType) (grouping :: Grouping) (params :: [NullityType]) @@ -185,6 +172,9 @@ newtype Expression = UnsafeExpression { renderExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Expression schema relations grouping params ty) where + renderSQL = renderExpression + {- | A `HasParameter` constraint is used to indicate a value that is supplied externally to a SQL statement. `Squeal.PostgreSQL.PQ.manipulateParams`, @@ -193,203 +183,302 @@ supplied externally to a SQL statement. separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -} -class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter +class KnownNat n => HasParameter (n :: Nat) + (schema :: SchemaType) (params :: [NullityType]) (ty :: NullityType) | n params -> ty where - param :: Expression relations grouping params ty - param = UnsafeExpression $ parenthesized $ + -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. + -- + -- >>> let expr = parameter @1 int4 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4) + -- >>> printSQL expr + -- ($1 :: int4) + parameter + :: TypeExpression schema (PGTypeOf ty) + -> Expression schema relations grouping params ty + parameter ty = UnsafeExpression $ parenthesized $ "$" <> renderNat (Proxy @n) <+> "::" - <+> renderTypeExpression (pgtype @(PGTypeOf ty)) -instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1) - => HasParameter 1 (ty1:tys) ty1 -instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty) - => HasParameter n (ty' : params) ty + <+> renderTypeExpression ty +instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1 +instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty) + => HasParameter n schema (ty' : params) ty + +-- | `param` takes a `Nat` using type application and for basic types, +-- infers a `TypeExpression`. +-- +-- >>> let expr = param @1 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4) +-- >>> printSQL expr +-- ($1 :: int4) +param + :: forall n schema params relations grouping ty + . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty) + => Expression schema relations grouping params ty -- ^ param +param = parameter @n pgtype instance (HasUnique relation relations columns, Has column columns ty) - => IsLabel column (Expression relations 'Ungrouped params ty) where + => IsLabel column (Expression schema relations 'Ungrouped params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) +instance (HasUnique relation relations columns, Has column columns ty) + => IsLabel column + (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where + fromLabel = fromLabel @column `As` Alias @column +instance (HasUnique relation relations columns, Has column columns ty) + => IsLabel column + (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where + fromLabel = fromLabel @column :* Nil instance (Has relation relations columns, Has column columns ty) - => IsQualified relation column (Expression relations 'Ungrouped params ty) where + => IsQualified relation column (Expression schema relations 'Ungrouped params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column - +instance (Has relation relations columns, Has column columns ty) + => IsQualified relation column + (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where + relation ! column = relation ! column `As` column +instance (Has relation relations columns, Has column columns ty) + => IsQualified relation column + (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where + relation ! column = relation ! column :* Nil + instance ( HasUnique relation relations columns , Has column columns ty , GroupedBy relation column bys ) => IsLabel column - (Expression relations ('Grouped bys) params ty) where + (Expression schema relations ('Grouped bys) params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) - +instance + ( HasUnique relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsLabel column + ( Aliased (Expression schema relations ('Grouped bys) params) + (column ::: ty) ) where + fromLabel = fromLabel @column `As` Alias @column +instance + ( HasUnique relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsLabel column + ( NP (Aliased (Expression schema relations ('Grouped bys) params)) + '[column ::: ty] ) where + fromLabel = fromLabel @column :* Nil + instance ( Has relation relations columns , Has column columns ty , GroupedBy relation column bys ) => IsQualified relation column - (Expression relations ('Grouped bys) params ty) where + (Expression schema relations ('Grouped bys) params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column +instance + ( Has relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsQualified relation column + (Aliased (Expression schema relations ('Grouped bys) params) + (column ::: ty)) where + relation ! column = relation ! column `As` column +instance + ( Has relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsQualified relation column + ( NP (Aliased (Expression schema relations ('Grouped bys) params)) + '[column ::: ty]) where + relation ! column = relation ! column :* Nil -- | analagous to `Nothing` -- --- >>> renderExpression $ null_ --- "NULL" -null_ :: Expression relations grouping params ('Null ty) +-- >>> printSQL null_ +-- NULL +null_ :: Expression schema rels grouping params ('Null ty) null_ = UnsafeExpression "NULL" -- | analagous to `Just` -- --- >>> renderExpression $ unNull true --- "TRUE" -unNull - :: Expression relations grouping params ('NotNull ty) - -- ^ not @NULL@ - -> Expression relations grouping params ('Null ty) -unNull = UnsafeExpression . renderExpression +-- >>> printSQL $ notNull true +-- TRUE +notNull + :: Expression schema rels grouping params ('NotNull ty) + -> Expression schema rels grouping params ('Null ty) +notNull = UnsafeExpression . renderExpression -- | return the leftmost value which is not NULL -- --- >>> renderExpression $ coalesce [null_, unNull true] false --- "COALESCE(NULL, TRUE, FALSE)" +-- >>> printSQL $ coalesce [null_, notNull true] false +-- COALESCE(NULL, TRUE, FALSE) coalesce - :: [Expression relations grouping params ('Null ty)] + :: [Expression schema relations grouping params ('Null ty)] -- ^ @NULL@s may be present - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('NotNull ty) coalesce nullxs notNullx = UnsafeExpression $ "COALESCE" <> parenthesized (commaSeparated ((renderExpression <$> nullxs) <> [renderExpression notNullx])) -- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@ -- --- >>> renderExpression $ fromNull true null_ --- "COALESCE(NULL, TRUE)" +-- >>> printSQL $ fromNull true null_ +-- COALESCE(NULL, TRUE) fromNull - :: Expression relations grouping params ('NotNull ty) + :: Expression schema relations grouping params ('NotNull ty) -- ^ what to convert @NULL@ to - -> Expression relations grouping params ('Null ty) - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('Null ty) + -> Expression schema relations grouping params ('NotNull ty) fromNull notNullx nullx = coalesce [nullx] notNullx --- | >>> renderExpression $ null_ & isNull --- "NULL IS NULL" +-- | >>> printSQL $ null_ & isNull +-- NULL IS NULL isNull - :: Expression relations grouping params ('Null ty) + :: Expression schema relations grouping params ('Null ty) -- ^ possibly @NULL@ - -> Condition relations grouping params + -> Condition schema relations grouping params isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL" --- | >>> renderExpression $ null_ & isn'tNull --- "NULL IS NOT NULL" -isn'tNull - :: Expression relations grouping params ('Null ty) +-- | >>> printSQL $ null_ & isNotNull +-- NULL IS NOT NULL +isNotNull + :: Expression schema relations grouping params ('Null ty) -- ^ possibly @NULL@ - -> Condition relations grouping params -isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" + -> Condition schema relations grouping params +isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@ -- --- >>> renderExpression $ matchNull true not_ null_ --- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END" +-- >>> printSQL $ matchNull true not_ null_ +-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END matchNull - :: Expression relations grouping params (nullty) + :: Expression schema relations grouping params (nullty) -- ^ what to convert @NULL@ to - -> ( Expression relations grouping params ('NotNull ty) - -> Expression relations grouping params (nullty) ) + -> ( Expression schema relations grouping params ('NotNull ty) + -> Expression schema relations grouping params (nullty) ) -- ^ function to perform when @NULL@ is absent - -> Expression relations grouping params ('Null ty) - -> Expression relations grouping params (nullty) + -> Expression schema relations grouping params ('Null ty) + -> Expression schema relations grouping params (nullty) matchNull y f x = ifThenElse (isNull x) y (f (UnsafeExpression (renderExpression x))) --- | right inverse to `fromNull`, if its arguments are equal then --- `nullIf` gives @NULL@. --- --- >>> :set -XTypeApplications -XDataKinds --- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1)) --- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)" +{-| right inverse to `fromNull`, if its arguments are equal then +`nullIf` gives @NULL@. + +>>> :set -XTypeApplications -XDataKinds +>>> let expr = nullIf false (param @1) :: Expression schema rels grp '[ 'NotNull 'PGbool] ('Null 'PGbool) +>>> printSQL expr +NULL IF (FALSE, ($1 :: bool)) +-} nullIf - :: Expression relations grouping params ('NotNull ty) + :: Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent - -> Expression relations grouping params ('Null ty) + -> Expression schema relations grouping params ('Null ty) nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized (renderExpression x <> ", " <> renderExpression y) --- | >>> renderExpression $ array [null_, unNull false, unNull true] --- "ARRAY[NULL, FALSE, TRUE]" +-- | >>> printSQL $ array [null_, notNull false, notNull true] +-- ARRAY[NULL, FALSE, TRUE] array - :: [Expression relations grouping params ('Null ty)] + :: [Expression schema relations grouping params ('Null ty)] -- ^ array elements - -> Expression relations grouping params (nullity ('PGvararray ty)) + -> Expression schema relations grouping params (nullity ('PGvararray ty)) array xs = UnsafeExpression $ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]" +instance (KnownSymbol label, label `In` labels) => IsPGlabel label + (Expression schema relations grouping params (nullity ('PGenum labels))) where + label = UnsafeExpression $ renderLabel (PGlabel @label) + +-- | 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" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8] +-- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex) +-- >>> printSQL i +-- ROW(0, 1) +row + :: SListI (Nulls fields) + => NP (Aliased (Expression schema relations grouping params)) (Nulls fields) + -- ^ zero or more expressions for the row field values + -> Expression schema relations grouping params (nullity ('PGcomposite fields)) +row exprs = UnsafeExpression $ "ROW" <> parenthesized + (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs) + +instance Has field fields ty => IsLabel field + ( Expression schema relation grouping params (nullity ('PGcomposite fields)) + -> Expression schema relation grouping params ('Null ty) ) where + fromLabel expr = UnsafeExpression $ + parenthesized (renderExpression expr) <> "." <> + fromString (symbolVal (Proxy @field)) + +instance Semigroup + (Expression schema relations grouping params (nullity ('PGvararray ty))) where + (<>) = unsafeBinaryOp "||" + instance Monoid - (Expression relations grouping params (nullity ('PGvararray ty))) where + (Expression schema relations grouping params (nullity ('PGvararray ty))) where mempty = array [] - mappend = unsafeBinaryOp "||" + mappend = (<>) --- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1] --- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))" +-- | >>> let expr = greatest currentTimestamp [param @1] :: Expression sch rels grp '[ 'NotNull 'PGtimestamptz] ('NotNull 'PGtimestamptz) +-- >>> printSQL expr +-- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone)) greatest - :: Expression relations grouping params (nullty) + :: Expression schema relations grouping params (nullty) -- ^ needs at least 1 argument - -> [Expression relations grouping params (nullty)] + -> [Expression schema relations grouping params (nullty)] -- ^ or more - -> Expression relations grouping params (nullty) + -> Expression schema relations grouping params (nullty) greatest x xs = UnsafeExpression $ "GREATEST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" --- | >>> renderExpression $ least currentTimestamp [null_] --- "LEAST(CURRENT_TIMESTAMP, NULL)" +-- | >>> printSQL $ least currentTimestamp [null_] +-- LEAST(CURRENT_TIMESTAMP, NULL) least - :: Expression relations grouping params (nullty) + :: Expression schema relations grouping params (nullty) -- ^ needs at least 1 argument - -> [Expression relations grouping params (nullty)] + -> [Expression schema relations grouping params (nullty)] -- ^ or more - -> Expression relations grouping params (nullty) + -> Expression schema relations grouping params (nullty) least x xs = UnsafeExpression $ "LEAST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" --- | >>> renderExpression $ unsafeBinaryOp "OR" true false --- "(TRUE OR FALSE)" +-- | >>> printSQL $ unsafeBinaryOp "OR" true false +-- (TRUE OR FALSE) unsafeBinaryOp :: ByteString -- ^ operator - -> Expression relations grouping params (ty0) - -> Expression relations grouping params (ty1) - -> Expression relations grouping params (ty2) + -> Expression schema relations grouping params (ty0) + -> Expression schema relations grouping params (ty1) + -> Expression schema relations grouping params (ty2) unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ renderExpression x <+> op <+> renderExpression y --- | >>> renderExpression $ unsafeUnaryOp "NOT" true --- "(NOT TRUE)" +-- | >>> printSQL $ unsafeUnaryOp "NOT" true +-- (NOT TRUE) unsafeUnaryOp :: ByteString -- ^ operator - -> Expression relations grouping params (ty0) - -> Expression relations grouping params (ty1) + -> Expression schema relations grouping params (ty0) + -> Expression schema relations grouping params (ty1) unsafeUnaryOp op x = UnsafeExpression $ parenthesized $ op <+> renderExpression x --- | >>> renderExpression $ unsafeFunction "f" true --- "f(TRUE)" +-- | >>> printSQL $ unsafeFunction "f" true +-- f(TRUE) unsafeFunction :: ByteString -- ^ function - -> Expression relations grouping params (xty) - -> Expression relations grouping params (yty) + -> Expression schema relations grouping params (xty) + -> Expression schema relations grouping params (yty) unsafeFunction fun x = UnsafeExpression $ fun <> parenthesized (renderExpression x) instance PGNum ty - => Num (Expression relations grouping params (nullity ty)) where + => Num (Expression schema relations grouping params (nullity ty)) where (+) = unsafeBinaryOp "+" (-) = unsafeBinaryOp "-" (*) = unsafeBinaryOp "*" @@ -401,12 +490,12 @@ instance PGNum ty . show instance (PGNum ty, PGFloating ty) => Fractional - (Expression relations grouping params (nullity ty)) where + (Expression schema relations grouping params (nullity ty)) where (/) = unsafeBinaryOp "/" fromRational x = fromInteger (numerator x) / fromInteger (denominator x) instance (PGNum ty, PGFloating ty) => Floating - (Expression relations grouping params (nullity ty)) where + (Expression schema relations grouping params (nullity ty)) where pi = UnsafeExpression "pi()" exp = unsafeFunction "exp" log = unsafeFunction "ln" @@ -429,18 +518,18 @@ instance (PGNum ty, PGFloating ty) => Floating -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = atan2_ pi 2 --- in renderExpression expression +-- in printSQL expression -- :} --- "atan2(pi(), 2)" +-- atan2(pi(), 2) atan2_ :: PGFloating float - => Expression relations grouping params (nullity float) + => Expression schema relations grouping params (nullity float) -- ^ numerator - -> Expression relations grouping params (nullity float) + -> Expression schema relations grouping params (nullity float) -- ^ denominator - -> Expression relations grouping params (nullity float) + -> Expression schema relations grouping params (nullity float) atan2_ y x = UnsafeExpression $ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")" @@ -448,14 +537,14 @@ atan2_ y x = UnsafeExpression $ -- represents a run-time type conversion. The cast will succeed only if a -- suitable type conversion operation has been defined. -- --- | >>> renderExpression $ true & cast int4 --- "(TRUE :: int4)" +-- | >>> printSQL $ true & cast int4 +-- (TRUE :: int4) cast - :: TypeExpression ('NoDef :=> 'Null ty1) + :: TypeExpression schema ty1 -- ^ type to cast as - -> Expression relations grouping params (nullity ty0) + -> Expression schema relations grouping params (nullity ty0) -- ^ value to convert - -> Expression relations grouping params (nullity ty1) + -> Expression schema relations grouping params (nullity ty1) cast ty x = UnsafeExpression $ parenthesized $ renderExpression x <+> "::" <+> renderTypeExpression ty @@ -463,135 +552,135 @@ cast ty x = UnsafeExpression $ parenthesized $ -- -- >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = 5 `quot_` 2 --- in renderExpression expression +-- in printSQL expression -- :} --- "(5 / 2)" +-- (5 / 2) quot_ :: PGIntegral int - => Expression relations grouping params (nullity int) + => Expression schema relations grouping params (nullity int) -- ^ numerator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) -- ^ denominator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) quot_ = unsafeBinaryOp "/" -- | remainder upon integer division -- -- >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = 5 `rem_` 2 --- in renderExpression expression +-- in printSQL expression -- :} --- "(5 % 2)" +-- (5 % 2) rem_ :: PGIntegral int - => Expression relations grouping params (nullity int) + => Expression schema relations grouping params (nullity int) -- ^ numerator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) -- ^ denominator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) rem_ = unsafeBinaryOp "%" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = trunc pi --- in renderExpression expression +-- in printSQL expression -- :} --- "trunc(pi())" +-- trunc(pi()) trunc :: PGFloating frac - => Expression relations grouping params (nullity frac) + => Expression schema relations grouping params (nullity frac) -- ^ fractional number - -> Expression relations grouping params (nullity frac) + -> Expression schema relations grouping params (nullity frac) trunc = unsafeFunction "trunc" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = round_ pi --- in renderExpression expression +-- in printSQL expression -- :} --- "round(pi())" +-- round(pi()) round_ :: PGFloating frac - => Expression relations grouping params (nullity frac) + => Expression schema relations grouping params (nullity frac) -- ^ fractional number - -> Expression relations grouping params (nullity frac) + -> Expression schema relations grouping params (nullity frac) round_ = unsafeFunction "round" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = ceiling_ pi --- in renderExpression expression +-- in printSQL expression -- :} --- "ceiling(pi())" +-- ceiling(pi()) ceiling_ :: PGFloating frac - => Expression relations grouping params (nullity frac) + => Expression schema relations grouping params (nullity frac) -- ^ fractional number - -> Expression relations grouping params (nullity frac) + -> Expression schema relations grouping params (nullity frac) ceiling_ = unsafeFunction "ceiling" -- | A `Condition` is a boolean valued `Expression`. While SQL allows -- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@, -- forcing one to handle the case of @NULL@ explicitly to produce -- a `Condition`. -type Condition relations grouping params = - Expression relations grouping params ('NotNull 'PGbool) +type Condition schema relations grouping params = + Expression schema relations grouping params ('NotNull 'PGbool) --- | >>> renderExpression true --- "TRUE" -true :: Condition relations grouping params +-- | >>> printSQL true +-- TRUE +true :: Condition schema relations grouping params true = UnsafeExpression "TRUE" --- | >>> renderExpression false --- "FALSE" -false :: Condition relations grouping params +-- | >>> printSQL false +-- FALSE +false :: Condition schema relations grouping params false = UnsafeExpression "FALSE" --- | >>> renderExpression $ not_ true --- "(NOT TRUE)" +-- | >>> printSQL $ not_ true +-- (NOT TRUE) not_ - :: Condition relations grouping params - -> Condition relations grouping params + :: Condition schema relations grouping params + -> Condition schema relations grouping params not_ = unsafeUnaryOp "NOT" --- | >>> renderExpression $ true .&& false --- "(TRUE AND FALSE)" +-- | >>> printSQL $ true .&& false +-- (TRUE AND FALSE) (.&&) - :: Condition relations grouping params - -> Condition relations grouping params - -> Condition relations grouping params + :: Condition schema relations grouping params + -> Condition schema relations grouping params + -> Condition schema relations grouping params (.&&) = unsafeBinaryOp "AND" --- | >>> renderExpression $ true .|| false --- "(TRUE OR FALSE)" +-- | >>> printSQL $ true .|| false +-- (TRUE OR FALSE) (.||) - :: Condition relations grouping params - -> Condition relations grouping params - -> Condition relations grouping params + :: Condition schema relations grouping params + -> Condition schema relations grouping params + -> Condition schema relations grouping params (.||) = unsafeBinaryOp "OR" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 --- in renderExpression expression +-- in printSQL expression -- :} --- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END" +-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END caseWhenThenElse - :: [ ( Condition relations grouping params - , Expression relations grouping params (ty) + :: [ ( Condition schema relations grouping params + , Expression schema relations grouping params (ty) ) ] -- ^ whens and thens - -> Expression relations grouping params (ty) + -> Expression schema relations grouping params (ty) -- ^ else - -> Expression relations grouping params (ty) + -> Expression schema relations grouping params (ty) caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat [ "CASE" , mconcat @@ -607,103 +696,103 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = ifThenElse true 1 0 --- in renderExpression expression +-- in printSQL expression -- :} --- "CASE WHEN TRUE THEN 1 ELSE 0 END" +-- CASE WHEN TRUE THEN 1 ELSE 0 END ifThenElse - :: Condition relations grouping params - -> Expression relations grouping params (ty) -- ^ then - -> Expression relations grouping params (ty) -- ^ else - -> Expression relations grouping params (ty) + :: Condition schema relations grouping params + -> Expression schema relations grouping params (ty) -- ^ then + -> Expression schema relations grouping params (ty) -- ^ else + -> Expression schema relations grouping params (ty) ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=` -- will produce @NULL@s if one of their arguments is @NULL@. -- --- >>> renderExpression $ unNull true .== null_ --- "(TRUE = NULL)" +-- >>> printSQL $ notNull true .== null_ +-- (TRUE = NULL) (.==) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.==) = unsafeBinaryOp "=" infix 4 .== --- | >>> renderExpression $ unNull true ./= null_ --- "(TRUE <> NULL)" +-- | >>> printSQL $ notNull true ./= null_ +-- (TRUE <> NULL) (./=) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (./=) = unsafeBinaryOp "<>" infix 4 ./= --- | >>> renderExpression $ unNull true .>= null_ --- "(TRUE >= NULL)" +-- | >>> printSQL $ notNull true .>= null_ +-- (TRUE >= NULL) (.>=) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.>=) = unsafeBinaryOp ">=" infix 4 .>= --- | >>> renderExpression $ unNull true .< null_ --- "(TRUE < NULL)" +-- | >>> printSQL $ notNull true .< null_ +-- (TRUE < NULL) (.<) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.<) = unsafeBinaryOp "<" infix 4 .< --- | >>> renderExpression $ unNull true .<= null_ --- "(TRUE <= NULL)" +-- | >>> printSQL $ notNull true .<= null_ +-- (TRUE <= NULL) (.<=) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.<=) = unsafeBinaryOp "<=" infix 4 .<= --- | >>> renderExpression $ unNull true .> null_ --- "(TRUE > NULL)" +-- | >>> printSQL $ notNull true .> null_ +-- (TRUE > NULL) (.>) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> renderExpression currentDate --- "CURRENT_DATE" +-- | >>> printSQL currentDate +-- CURRENT_DATE currentDate - :: Expression relations grouping params (nullity 'PGdate) + :: Expression schema relations grouping params (nullity 'PGdate) currentDate = UnsafeExpression "CURRENT_DATE" --- | >>> renderExpression currentTime --- "CURRENT_TIME" +-- | >>> printSQL currentTime +-- CURRENT_TIME currentTime - :: Expression relations grouping params (nullity 'PGtimetz) + :: Expression schema relations grouping params (nullity 'PGtimetz) currentTime = UnsafeExpression "CURRENT_TIME" --- | >>> renderExpression currentTimestamp --- "CURRENT_TIMESTAMP" +-- | >>> printSQL currentTimestamp +-- CURRENT_TIMESTAMP currentTimestamp - :: Expression relations grouping params (nullity 'PGtimestamptz) + :: Expression schema relations grouping params (nullity 'PGtimestamptz) currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP" --- | >>> renderExpression localTime --- "LOCALTIME" +-- | >>> printSQL localTime +-- LOCALTIME localTime - :: Expression relations grouping params (nullity 'PGtime) + :: Expression schema relations grouping params (nullity 'PGtime) localTime = UnsafeExpression "LOCALTIME" --- | >>> renderExpression localTimestamp --- "LOCALTIMESTAMP" +-- | >>> printSQL localTimestamp +-- LOCALTIMESTAMP localTimestamp - :: Expression relations grouping params (nullity 'PGtimestamp) + :: Expression schema relations grouping params (nullity 'PGtimestamp) localTimestamp = UnsafeExpression "LOCALTIMESTAMP" {----------------------------------------- @@ -711,7 +800,7 @@ text -----------------------------------------} instance IsString - (Expression relations grouping params (nullity 'PGtext)) where + (Expression schema relations grouping params (nullity 'PGtext)) where fromString str = UnsafeExpression $ "E\'" <> fromString (escape =<< str) <> "\'" where @@ -726,33 +815,37 @@ instance IsString '\\' -> "\\\\" c -> [c] +instance Semigroup + (Expression schema relations grouping params (nullity 'PGtext)) where + (<>) = unsafeBinaryOp "||" + instance Monoid - (Expression relations grouping params (nullity 'PGtext)) where + (Expression schema relations grouping params (nullity 'PGtext)) where mempty = fromString "" - mappend = unsafeBinaryOp "||" + mappend = (<>) --- | >>> renderExpression $ lower "ARRRGGG" --- "lower(E'ARRRGGG')" +-- | >>> printSQL $ lower "ARRRGGG" +-- lower(E'ARRRGGG') lower - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to lower case - -> Expression relations grouping params (nullity 'PGtext) + -> Expression schema relations grouping params (nullity 'PGtext) lower = unsafeFunction "lower" --- | >>> renderExpression $ upper "eeee" --- "upper(E'eeee')" +-- | >>> printSQL $ upper "eeee" +-- upper(E'eeee') upper - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to upper case - -> Expression relations grouping params (nullity 'PGtext) + -> Expression schema relations grouping params (nullity 'PGtext) upper = unsafeFunction "upper" --- | >>> renderExpression $ charLength "four" --- "char_length(E'four')" +-- | >>> printSQL $ charLength "four" +-- char_length(E'four') charLength - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to measure - -> Expression relations grouping params (nullity 'PGint4) + -> Expression schema relations grouping params (nullity 'PGint4) charLength = unsafeFunction "char_length" -- | The `like` expression returns true if the @string@ matches @@ -762,14 +855,14 @@ charLength = unsafeFunction "char_length" -- in pattern stands for (matches) any single character; a percent sign (%) -- matches any sequence of zero or more characters. -- --- >>> renderExpression $ "abc" `like` "a%" --- "(E'abc' LIKE E'a%')" +-- >>> printSQL $ "abc" `like` "a%" +-- (E'abc' LIKE E'a%') like - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string - -> Expression relations grouping params (nullity 'PGtext) + -> Expression schema relations grouping params (nullity 'PGtext) -- ^ pattern - -> Expression relations grouping params (nullity 'PGbool) + -> Expression schema relations grouping params (nullity 'PGbool) like = unsafeBinaryOp "LIKE" {----------------------------------------- @@ -779,54 +872,54 @@ aggregation -- | escape hatch to define aggregate functions unsafeAggregate :: ByteString -- ^ aggregate function - -> Expression relations 'Ungrouped params (xty) - -> Expression relations ('Grouped bys) params (yty) + -> Expression schema relations 'Ungrouped params (xty) + -> Expression schema relations ('Grouped bys) params (yty) unsafeAggregate fun x = UnsafeExpression $ mconcat [fun, "(", renderExpression x, ")"] -- | escape hatch to define aggregate functions over distinct values unsafeAggregateDistinct :: ByteString -- ^ aggregate function - -> Expression relations 'Ungrouped params (xty) - -> Expression relations ('Grouped bys) params (yty) + -> Expression schema relations 'Ungrouped params (xty) + -> Expression schema relations ('Grouped bys) params (yty) unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat [fun, "(DISTINCT ", renderExpression x, ")"] -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric) +-- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric) -- expression = sum_ #col --- in renderExpression expression +-- in printSQL expression -- :} --- "sum(\"col\")" +-- sum("col") sum_ :: PGNum ty - => Expression relations 'Ungrouped params (nullity ty) + => Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to sum - -> Expression relations ('Grouped bys) params (nullity ty) + -> Expression schema relations ('Grouped bys) params (nullity ty) sum_ = unsafeAggregate "sum" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric) -- expression = sumDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "sum(DISTINCT \"col\")" +-- sum(DISTINCT "col") sumDistinct :: PGNum ty - => Expression relations 'Ungrouped params (nullity ty) + => Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to sum - -> Expression relations ('Grouped bys) params (nullity ty) + -> Expression schema relations ('Grouped bys) params (nullity ty) sumDistinct = unsafeAggregateDistinct "sum" -- | A constraint for `PGType`s that you can take averages of and the resulting -- `PGType`. class PGAvg ty avg | ty -> avg where avg, avgDistinct - :: Expression relations 'Ungrouped params (nullity ty) + :: Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to average - -> Expression relations ('Grouped bys) params (nullity avg) + -> Expression schema relations ('Grouped bys) params (nullity avg) avg = unsafeAggregate "avg" avgDistinct = unsafeAggregateDistinct "avg" instance PGAvg 'PGint2 'PGnumeric @@ -839,312 +932,281 @@ instance PGAvg 'PGinterval 'PGinterval -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitAnd #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_and(\"col\")" +-- bit_and("col") bitAnd :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitAnd = unsafeAggregate "bit_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitOr #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_or(\"col\")" +-- bit_or("col") bitOr :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitOr = unsafeAggregate "bit_or" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitAndDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_and(DISTINCT \"col\")" +-- bit_and(DISTINCT "col") bitAndDistinct :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitAndDistinct = unsafeAggregateDistinct "bit_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitOrDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_or(DISTINCT \"col\")" +-- bit_or(DISTINCT "col") bitOrDistinct :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitOrDistinct = unsafeAggregateDistinct "bit_or" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolAnd #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_and(\"col\")" +-- bool_and("col") boolAnd - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolAnd = unsafeAggregate "bool_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolOr #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_or(\"col\")" +-- bool_or("col") boolOr - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolOr = unsafeAggregate "bool_or" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolAndDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_and(DISTINCT \"col\")" +-- bool_and(DISTINCT "col") boolAndDistinct - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolAndDistinct = unsafeAggregateDistinct "bool_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolOrDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_or(DISTINCT \"col\")" +-- bool_or(DISTINCT "col") boolOrDistinct - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolOrDistinct = unsafeAggregateDistinct "bool_or" -- | A special aggregation that does not require an input -- --- >>> renderExpression countStar --- "count(*)" +-- >>> printSQL countStar +-- count(*) countStar - :: Expression relations ('Grouped bys) params ('NotNull 'PGint8) + :: Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) countStar = UnsafeExpression $ "count(*)" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) -- expression = count #col --- in renderExpression expression +-- in printSQL expression -- :} --- "count(\"col\")" +-- count("col") count - :: Expression relations 'Ungrouped params ty + :: Expression schema relations 'Ungrouped params ty -- ^ what to count - -> Expression relations ('Grouped bys) params ('NotNull 'PGint8) + -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) count = unsafeAggregate "count" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) -- expression = countDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "count(DISTINCT \"col\")" +-- count(DISTINCT "col") countDistinct - :: Expression relations 'Ungrouped params ty + :: Expression schema relations 'Ungrouped params ty -- ^ what to count - -> Expression relations ('Grouped bys) params ('NotNull 'PGint8) + -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) countDistinct = unsafeAggregateDistinct "count" -- | synonym for `boolAnd` -- -- >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = every #col --- in renderExpression expression +-- in printSQL expression -- :} --- "every(\"col\")" +-- every("col") every - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) every = unsafeAggregate "every" -- | synonym for `boolAndDistinct` -- -- >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = everyDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "every(DISTINCT \"col\")" +-- every(DISTINCT "col") everyDistinct - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) everyDistinct = unsafeAggregateDistinct "every" -- | minimum and maximum aggregation max_, min_, maxDistinct, minDistinct - :: Expression relations 'Ungrouped params (nullity ty) + :: Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity ty) + -> Expression schema relations ('Grouped bys) params (nullity ty) max_ = unsafeAggregate "max" min_ = unsafeAggregate "min" maxDistinct = unsafeAggregateDistinct "max" minDistinct = unsafeAggregateDistinct "min" -{----------------------------------------- -tables ------------------------------------------} - --- | A `Table` from a table expression is a way --- to call a table reference by its alias. -newtype Table - (schema :: TablesType) - (columns :: RelationType) - = UnsafeTable { renderTable :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance - ( Has alias schema table - , relation ~ ColumnsToRelation (TableToColumns table) - ) => IsLabel alias (Table schema relation) where - fromLabel = UnsafeTable $ renderAlias (Alias @alias) - {----------------------------------------- type expressions -----------------------------------------} -- | `TypeExpression`s are used in `cast`s and `createTable` commands. -newtype TypeExpression (ty :: ColumnType) +newtype TypeExpression (schema :: SchemaType) (ty :: PGType) = UnsafeTypeExpression { renderTypeExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance (Has alias schema ('Typedef ty)) + => IsLabel alias (TypeExpression schema ty) where + fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias)) + -- | logical Boolean (true/false) -bool :: TypeExpression ('NoDef :=> 'Null 'PGbool) +bool :: TypeExpression schema 'PGbool bool = UnsafeTypeExpression "bool" -- | signed two-byte integer -int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2) +int2, smallint :: TypeExpression schema 'PGint2 int2 = UnsafeTypeExpression "int2" smallint = UnsafeTypeExpression "smallint" -- | signed four-byte integer -int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4) +int4, int, integer :: TypeExpression schema 'PGint4 int4 = UnsafeTypeExpression "int4" int = UnsafeTypeExpression "int" integer = UnsafeTypeExpression "integer" -- | signed eight-byte integer -int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8) +int8, bigint :: TypeExpression schema 'PGint8 int8 = UnsafeTypeExpression "int8" bigint = UnsafeTypeExpression "bigint" -- | arbitrary precision numeric type -numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric) +numeric :: TypeExpression schema 'PGnumeric numeric = UnsafeTypeExpression "numeric" -- | single precision floating-point number (4 bytes) -float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4) +float4, real :: TypeExpression schema 'PGfloat4 float4 = UnsafeTypeExpression "float4" real = UnsafeTypeExpression "real" -- | double precision floating-point number (8 bytes) -float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8) +float8, doublePrecision :: TypeExpression schema 'PGfloat8 float8 = UnsafeTypeExpression "float8" doublePrecision = UnsafeTypeExpression "double precision" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint2` -serial2, smallserial - :: TypeExpression ('Def :=> 'NotNull 'PGint2) -serial2 = UnsafeTypeExpression "serial2" -smallserial = UnsafeTypeExpression "smallserial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint4` -serial4, serial - :: TypeExpression ('Def :=> 'NotNull 'PGint4) -serial4 = UnsafeTypeExpression "serial4" -serial = UnsafeTypeExpression "serial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint8` -serial8, bigserial - :: TypeExpression ('Def :=> 'NotNull 'PGint8) -serial8 = UnsafeTypeExpression "serial8" -bigserial = UnsafeTypeExpression "bigserial" -- | variable-length character string -text :: TypeExpression ('NoDef :=> 'Null 'PGtext) +text :: TypeExpression schema 'PGtext text = UnsafeTypeExpression "text" -- | fixed-length character string char, character :: (KnownNat n, 1 <= n) => proxy n - -> TypeExpression ('NoDef :=> 'Null ('PGchar n)) + -> TypeExpression schema ('PGchar n) char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")" character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")" -- | variable-length character string varchar, characterVarying :: (KnownNat n, 1 <= n) => proxy n - -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n)) + -> TypeExpression schema ('PGvarchar n) varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")" characterVarying p = UnsafeTypeExpression $ "character varying(" <> renderNat p <> ")" -- | binary data ("byte array") -bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea) +bytea :: TypeExpression schema 'PGbytea bytea = UnsafeTypeExpression "bytea" -- | date and time (no time zone) -timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp) +timestamp :: TypeExpression schema 'PGtimestamp timestamp = UnsafeTypeExpression "timestamp" -- | date and time, including time zone -timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz) +timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone" -- | calendar date (year, month, day) -date :: TypeExpression ('NoDef :=> 'Null 'PGdate) +date :: TypeExpression schema 'PGdate date = UnsafeTypeExpression "date" -- | time of day (no time zone) -time :: TypeExpression ('NoDef :=> 'Null 'PGtime) +time :: TypeExpression schema 'PGtime time = UnsafeTypeExpression "time" -- | time of day, including time zone -timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz) +timeWithTimeZone :: TypeExpression schema 'PGtimetz timeWithTimeZone = UnsafeTypeExpression "time with time zone" -- | time span -interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval) +interval :: TypeExpression schema 'PGinterval interval = UnsafeTypeExpression "interval" -- | universally unique identifier -uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid) +uuid :: TypeExpression schema 'PGuuid uuid = UnsafeTypeExpression "uuid" -- | IPv4 or IPv6 host address -inet :: TypeExpression ('NoDef :=> 'Null 'PGinet) +inet :: TypeExpression schema 'PGinet inet = UnsafeTypeExpression "inet" -- | textual JSON data -json :: TypeExpression ('NoDef :=> 'Null 'PGjson) +json :: TypeExpression schema 'PGjson json = UnsafeTypeExpression "json" -- | binary JSON data, decomposed -jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb) +jsonb :: TypeExpression schema 'PGjsonb jsonb = UnsafeTypeExpression "jsonb" -- | variable length array vararray - :: TypeExpression ('NoDef :=> 'Null pg) - -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg)) + :: TypeExpression schema pg + -> TypeExpression schema ('PGvararray pg) vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]" -- | fixed length array -- @@ -1153,52 +1215,36 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]" fixarray :: KnownNat n => proxy n - -> TypeExpression ('NoDef :=> 'Null pg) - -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg)) + -> TypeExpression schema pg + -> TypeExpression schema ('PGfixarray n pg) fixarray p ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[" <> renderNat p <> "]" --- | used in `createTable` commands as a column constraint to ensure --- @NULL@ is not present -notNull - :: TypeExpression (def :=> 'Null ty) - -> TypeExpression (def :=> 'NotNull ty) -notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL" - --- | used in `createTable` commands as a column constraint to give a default -default_ - :: Expression '[] 'Ungrouped '[] ty - -> TypeExpression ('NoDef :=> ty) - -> TypeExpression ('Def :=> ty) -default_ x ty = UnsafeTypeExpression $ - renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x - -- | `pgtype` is a demoted version of a `PGType` -class PGTyped (ty :: PGType) where - pgtype :: TypeExpression ('NoDef :=> 'Null ty) -instance PGTyped 'PGbool where pgtype = bool -instance PGTyped 'PGint2 where pgtype = int2 -instance PGTyped 'PGint4 where pgtype = int4 -instance PGTyped 'PGint8 where pgtype = int8 -instance PGTyped 'PGnumeric where pgtype = numeric -instance PGTyped 'PGfloat4 where pgtype = float4 -instance PGTyped 'PGfloat8 where pgtype = float8 -instance PGTyped 'PGtext where pgtype = text +class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty +instance PGTyped schema 'PGbool where pgtype = bool +instance PGTyped schema 'PGint2 where pgtype = int2 +instance PGTyped schema 'PGint4 where pgtype = int4 +instance PGTyped schema 'PGint8 where pgtype = int8 +instance PGTyped schema 'PGnumeric where pgtype = numeric +instance PGTyped schema 'PGfloat4 where pgtype = float4 +instance PGTyped schema 'PGfloat8 where pgtype = float8 +instance PGTyped schema 'PGtext where pgtype = text instance (KnownNat n, 1 <= n) - => PGTyped ('PGchar n) where pgtype = char (Proxy @n) + => PGTyped schema ('PGchar n) where pgtype = char (Proxy @n) instance (KnownNat n, 1 <= n) - => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n) -instance PGTyped 'PGbytea where pgtype = bytea -instance PGTyped 'PGtimestamp where pgtype = timestamp -instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone -instance PGTyped 'PGdate where pgtype = date -instance PGTyped 'PGtime where pgtype = time -instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone -instance PGTyped 'PGinterval where pgtype = interval -instance PGTyped 'PGuuid where pgtype = uuid -instance PGTyped 'PGjson where pgtype = json -instance PGTyped 'PGjsonb where pgtype = jsonb -instance PGTyped ty => PGTyped ('PGvararray ty) where - pgtype = vararray (pgtype @ty) -instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where - pgtype = fixarray (Proxy @n) (pgtype @ty) + => PGTyped schema ('PGvarchar n) where pgtype = varchar (Proxy @n) +instance PGTyped schema 'PGbytea where pgtype = bytea +instance PGTyped schema 'PGtimestamp where pgtype = timestamp +instance PGTyped schema 'PGtimestamptz where pgtype = timestampWithTimeZone +instance PGTyped schema 'PGdate where pgtype = date +instance PGTyped schema 'PGtime where pgtype = time +instance PGTyped schema 'PGtimetz where pgtype = timeWithTimeZone +instance PGTyped schema 'PGinterval where pgtype = interval +instance PGTyped schema 'PGuuid where pgtype = uuid +instance PGTyped schema 'PGjson where pgtype = json +instance PGTyped schema 'PGjsonb where pgtype = jsonb +instance PGTyped schema ty => PGTyped schema ('PGvararray ty) where + pgtype = vararray (pgtype @schema @ty) +instance (KnownNat n, PGTyped schema ty) => PGTyped schema ('PGfixarray n ty) where + pgtype = fixarray (Proxy @n) (pgtype @schema @ty) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index 4a2d0642..b83f8a56 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -9,17 +9,13 @@ Squeal data manipulation language. -} {-# LANGUAGE - DataKinds - , DeriveDataTypeable - , DeriveGeneric + DeriveGeneric , FlexibleContexts , GADTs , GeneralizedNewtypeDeriving - , KindSignatures , LambdaCase , OverloadedStrings , RankNTypes - , StandaloneDeriving , TypeInType , TypeOperators #-} @@ -54,7 +50,6 @@ import Control.DeepSeq import Data.ByteString hiding (foldr) import Data.Monoid -import qualified Data.ByteString as ByteString import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC @@ -73,55 +68,55 @@ simple insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[] + , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[] manipulation = insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT);" +INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) parameterized insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[] manipulation = insertRow_ #tab (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4));" +INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4)) returning insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] + , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '["fromOnly" ::: 'NotNull 'PGint4] manipulation = insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil)) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\";" +INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) RETURNING "col1" AS "fromOnly" upsert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "sum" ::: 'NotNull 'PGint4] manipulation = insertRows #tab @@ -131,73 +126,76 @@ let (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) [#col1 .== #col2]) (Returning $ (#col1 + #col2) `As` #sum :* Nil) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET \"col1\" = 2 WHERE (\"col1\" = \"col2\") RETURNING (\"col1\" + \"col2\") AS \"sum\";" +INSERT INTO "tab" ("col1", "col2") VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET "col1" = 2 WHERE ("col1" = "col2") RETURNING ("col1" + "col2") AS "sum" query insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 - ] - , "other_tab" ::: '[] :=> + ]) + , "other_tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 - ] + ]) ] '[] '[] - manipulation = + manipulation = insertQuery_ #tab (selectStar (from (table (#other_tab `As` #t)))) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\";" +INSERT INTO "tab" SELECT * FROM "other_tab" AS "t" update: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[] manipulation = update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) (#col1 ./= #col2) -in renderManipulation manipulation +in printSQL manipulation :} -"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\");" +UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2") delete: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "col1" ::: 'NotNull 'PGint4 , "col2" ::: 'NotNull 'PGint4 ] manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar -in renderManipulation manipulation +in printSQL manipulation :} -"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;" +DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING * -} newtype Manipulation - (schema :: TablesType) + (schema :: SchemaType) (params :: [NullityType]) (columns :: RelationType) = UnsafeManipulation { renderManipulation :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Manipulation schema params columns) where + renderSQL = renderManipulation + -- | Convert a `Query` into a `Manipulation`. queryStatement :: Query schema params columns -> Manipulation schema params columns -queryStatement q = UnsafeManipulation $ renderQuery q <> ";" +queryStatement q = UnsafeManipulation $ renderQuery q {----------------------------------------- INSERT statements @@ -213,27 +211,27 @@ INSERT statements insertRows :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert - -> ConflictClause columns params + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert + -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert + -> ConflictClause schema columns params -- ^ what to do in case of constraint conflict - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results -insertRows tab row rows conflict returning = UnsafeManipulation $ +insertRows tab rw rws conflict returning = UnsafeManipulation $ "INSERT" <+> "INTO" <+> renderAlias tab - <+> parenthesized (renderCommaSeparated renderAliasPart row) + <+> parenthesized (renderCommaSeparated renderAliasPart rw) <+> "VALUES" <+> commaSeparated ( parenthesized - . renderCommaSeparated renderColumnValuePart <$> row:rows ) + . renderCommaSeparated renderColumnValuePart <$> rw:rws ) <> renderConflictClause conflict <> renderReturningClause returning where renderAliasPart, renderColumnValuePart - :: Aliased (ColumnValue '[] params) ty -> ByteString + :: Aliased (ColumnValue schema '[] params) ty -> ByteString renderAliasPart (_ `As` name) = renderAlias name renderColumnValuePart (value `As` _) = case value of Default -> "DEFAULT" @@ -243,49 +241,49 @@ insertRows tab row rows conflict returning = UnsafeManipulation $ insertRow :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> ConflictClause columns params + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert + -> ConflictClause schema columns params -- ^ what to do in case of constraint conflict - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results -insertRow tab row = insertRows tab row [] +insertRow tab rw = insertRows tab rw [] -- | Insert multiple rows returning `Nil` and raising an error on conflicts. insertRows_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert + -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert -> Manipulation schema params '[] -insertRows_ tab row rows = - insertRows tab row rows OnConflictDoRaise (Returning Nil) +insertRows_ tab rw rws = + insertRows tab rw rws OnConflictDoRaise (Returning Nil) -- | Insert a single row returning `Nil` and raising an error on conflicts. insertRow_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert -> Manipulation schema params '[] -insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil) +insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil) -- | Insert a `Query`. insertQuery :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) - -> ConflictClause columns params + -> ConflictClause schema columns params -- ^ what to do in case of constraint conflict - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results insertQuery tab query conflict returning = UnsafeManipulation $ "INSERT" <+> "INTO" <+> renderAlias tab @@ -296,7 +294,7 @@ insertQuery tab query conflict returning = UnsafeManipulation $ -- | Insert a `Query` returning `Nil` and raising an error on conflicts. insertQuery_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) @@ -304,21 +302,22 @@ insertQuery_ insertQuery_ tab query = insertQuery tab query OnConflictDoRaise (Returning Nil) --- | `ColumnValue`s are values to insert or update in a row +-- | `ColumnValue`s are values to insert or update in a row. -- `Same` updates with the same value. --- `Default` inserts or updates with the @DEFAULT@ value --- `Set` a value to be an `Expression`, relative to the given --- row for an update, and closed for an insert. +-- `Default` inserts or updates with the @DEFAULT@ value. +-- `Set` sets a value to be an `Expression`, which can refer to +-- existing value in the row for an update. data ColumnValue + (schema :: SchemaType) (columns :: RelationType) (params :: [NullityType]) (ty :: ColumnType) where - Same :: ColumnValue (column ': columns) params ty - Default :: ColumnValue columns params ('Def :=> ty) + Same :: ColumnValue schema (column ': columns) params ty + Default :: ColumnValue schema columns params ('Def :=> ty) Set - :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty) - -> ColumnValue columns params (constraint :=> ty) + :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty) + -> ColumnValue schema columns params (constraint :=> ty) -- | A `ReturningClause` computes and return value(s) based -- on each row actually inserted, updated or deleted. This is primarily @@ -331,46 +330,47 @@ data ColumnValue -- in the row. Use @Returning Nil@ in the common case where no return -- values are desired. data ReturningClause + (schema :: SchemaType) (columns :: ColumnsType) (params :: [NullityType]) (results :: RelationType) where ReturningStar :: results ~ ColumnsToRelation columns - => ReturningClause columns params results + => ReturningClause schema columns params results Returning :: rel ~ ColumnsToRelation columns - => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results - -> ReturningClause columns params results + => NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results + -> ReturningClause schema columns params results -- | Render a `ReturningClause`. renderReturningClause :: SOP.SListI results - => ReturningClause params columns results + => ReturningClause schema params columns results -> ByteString renderReturningClause = \case - ReturningStar -> " RETURNING *;" - Returning Nil -> ";" + ReturningStar -> " RETURNING *" + Returning Nil -> "" Returning results -> " RETURNING" - <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";" + <+> renderCommaSeparated (renderAliasedAs renderExpression) results -- | A `ConflictClause` specifies an action to perform upon a constraint -- violation. `OnConflictDoRaise` will raise an error. -- `OnConflictDoNothing` simply avoids inserting a row. -- `OnConflictDoUpdate` updates the existing row that conflicts with the row -- proposed for insertion. -data ConflictClause (columns :: ColumnsType) params where - OnConflictDoRaise :: ConflictClause columns params - OnConflictDoNothing :: ConflictClause columns params +data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where + OnConflictDoRaise :: ConflictClause schema columns params + OnConflictDoNothing :: ConflictClause schema columns params OnConflictDoUpdate - :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns - -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params] - -> ConflictClause columns params + :: NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns + -> [Condition schema '[table ::: ColumnsToRelation columns] 'Ungrouped params] + -> ConflictClause schema columns params -- | Render a `ConflictClause`. renderConflictClause :: SOP.SListI columns - => ConflictClause columns params + => ConflictClause schema columns params -> ByteString renderConflictClause = \case OnConflictDoRaise -> "" @@ -383,7 +383,7 @@ renderConflictClause = \case wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs) where renderUpdate - :: Aliased (ColumnValue columns params) column + :: Aliased (ColumnValue schema columns params) column -> Maybe ByteString renderUpdate = \case Same `As` _ -> Nothing @@ -401,14 +401,14 @@ UPDATE statements update :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to update - -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns + -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to perform update on a row - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results update tab columns wh returning = UnsafeManipulation $ "UPDATE" @@ -419,7 +419,7 @@ update tab columns wh returning = UnsafeManipulation $ <> renderReturningClause returning where renderUpdate - :: Aliased (ColumnValue columns params) column + :: Aliased (ColumnValue schema columns params) column -> Maybe ByteString renderUpdate = \case Same `As` _ -> Nothing @@ -431,12 +431,12 @@ update tab columns wh returning = UnsafeManipulation $ -- | Update a row returning `Nil`. update_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to update - -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns + -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to perform update on a row -> Manipulation schema params '[] update_ tab columns wh = update tab columns wh (Returning Nil) @@ -448,12 +448,12 @@ DELETE statements -- | Delete rows of a table. deleteFrom :: ( SOP.SListI results - , Has tab schema table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to delete a row - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results deleteFrom tab wh returning = UnsafeManipulation $ "DELETE FROM" <+> renderAlias tab @@ -462,10 +462,10 @@ deleteFrom tab wh returning = UnsafeManipulation $ -- | Delete rows returning `Nil`. deleteFrom_ - :: ( Has tab schema table + :: ( Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to delete a row -> Manipulation schema params '[] deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil) @@ -482,18 +482,18 @@ WITH statements -- -- >>> :{ -- let --- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[] +-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[] -- manipulation = with -- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil) --- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t))))) --- in renderManipulation manipulation +-- (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\";" +-- WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t" with :: SOP.SListI commons => NP (Aliased (Manipulation schema params)) commons -- ^ common table expressions - -> Manipulation (Join (RelationsToTables commons) schema) params results + -> Manipulation (With commons schema) params results -> Manipulation schema params results with commons manipulation = UnsafeManipulation $ "WITH" <+> renderCommaSeparated renderCommon commons @@ -504,9 +504,4 @@ with commons manipulation = UnsafeManipulation $ -> ByteString renderCommon (common `As` alias) = renderAlias alias <+> "AS" <+> - let - str = renderManipulation common - len = ByteString.length str - str' = ByteString.take (len - 1) str -- remove ';' - in - parenthesized str' + parenthesized (renderManipulation common) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index b3c5b598..c8610541 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -31,31 +31,31 @@ type EmailsTable = >>> :{ let - makeUsers :: Migration IO '[] '["users" ::: UsersTable] + makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable] makeUsers = Migration { name = "make users table" , up = void . define $ createTable #users ( serial `As` #id :* - (text & notNull) `As` #name :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) , down = void . define $ dropTable #users } :} >>> :{ let - makeEmails :: Migration IO '["users" ::: UsersTable] - '["users" ::: UsersTable, "emails" ::: EmailsTable] + makeEmails :: Migration IO '["users" ::: 'Table UsersTable] + '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable] makeEmails = Migration { name = "make emails table" , up = void . define $ createTable #emails ( serial `As` #id :* - (int & notNull) `As` #user_id :* - text `As` #email :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_emails :* - foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) , down = void . define $ dropTable #emails } @@ -68,7 +68,7 @@ Now that we have a couple migrations we can chain them together. >>> :{ let numMigrations - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => PQ schema schema IO () numMigrations = do result <- runQuery (selectStar (from (table (#schema_migrations `As` #m)))) @@ -90,9 +90,7 @@ Row 0 -} {-# LANGUAGE - ScopedTypeVariables - , OverloadedStrings - , DataKinds + DataKinds , GADTs , LambdaCase , PolyKinds @@ -162,8 +160,8 @@ migrateUp :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io () migrateUp migration = define createMigrations @@ -175,8 +173,8 @@ migrateUp migration = :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io () upMigrations = \case Done -> return () @@ -185,8 +183,8 @@ migrateUp migration = upMigration :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io () upMigration step = queryExecuted step @@ -202,8 +200,8 @@ migrateUp migration = queryExecuted :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io Row queryExecuted step = do result <- runQueryParams selectMigration (Only (name step)) @@ -218,8 +216,8 @@ migrateDown :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io () migrateDown migrations = define createMigrations @@ -230,8 +228,8 @@ migrateDown migrations = downMigrations :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io () downMigrations = \case Done -> return () @@ -240,8 +238,8 @@ migrateDown migrations = downMigration :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io () downMigration step = queryExecuted step @@ -257,8 +255,8 @@ migrateDown migrations = queryExecuted :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io Row queryExecuted step = do result <- runQueryParams selectMigration (Only (name step)) @@ -283,18 +281,18 @@ type MigrationsTable = -- | Creates a `MigrationsTable` if it does not already exist. createMigrations - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Definition schema schema createMigrations = createTableIfNotExists #schema_migrations - ( (text & notNull) `As` #name :* - (timestampWithTimeZone & notNull & default_ currentTimestamp) + ( (text & notNullable) `As` #name :* + (timestampWithTimeZone & notNullable & default_ currentTimestamp) `As` #executed_at :* Nil ) - ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil ) + ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil ) -- | Inserts a `Migration` into the `MigrationsTable` insertMigration - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Manipulation schema '[ 'NotNull 'PGtext] '[] insertMigration = insertRow_ #schema_migrations ( Set (param @1) `As` #name :* @@ -302,14 +300,14 @@ insertMigration = insertRow_ #schema_migrations -- | Deletes a `Migration` from the `MigrationsTable` deleteMigration - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Manipulation schema '[ 'NotNull 'PGtext ] '[] deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1) -- | Selects a `Migration` from the `MigrationsTable`, returning -- the time at which it was executed. selectMigration - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Query schema '[ 'NotNull 'PGtext ] '[ "executed_at" ::: 'NotNull 'PGtimestamptz ] selectMigration = select diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs index 6e489523..258b5f86 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs @@ -20,15 +20,10 @@ of executing Squeal commands. {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE - DataKinds - , DefaultSignatures + DefaultSignatures , FunctionalDependencies - , PolyKinds - , DeriveFunctor , FlexibleContexts , FlexibleInstances - , MagicHash - , MultiParamTypeClasses , OverloadedStrings , RankNTypes , ScopedTypeVariables @@ -160,8 +155,8 @@ lowerConnection (K conn) = K conn -- | We keep track of the schema via an Atkey indexed state monad transformer, -- `PQ`. newtype PQ - (schema0 :: TablesType) - (schema1 :: TablesType) + (schema0 :: SchemaType) + (schema1 :: SchemaType) (m :: Type -> Type) (x :: Type) = PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) } @@ -171,7 +166,7 @@ instance Monad m => Functor (PQ schema0 schema1 m) where K x <- pq conn return $ K (f x) --- | Run a `PQ` and keep the result and the `Connection`. +-- | Run a `PQ` and keep the result and the `Connection`. runPQ :: Functor m => PQ schema0 schema1 m x @@ -181,7 +176,7 @@ 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 `Connection`. +-- | Execute a `PQ` and discard the result but keep the `Connection`. execPQ :: Functor m => PQ schema0 schema1 m x @@ -217,6 +212,7 @@ class IndexedMonadTransPQ pq where :: Monad m => pq schema0 schema1 m (pq schema1 schema2 m y) -> pq schema0 schema2 m y + pqJoin pq = pq & pqBind id -- | indexed analog of `=<<` pqBind @@ -231,6 +227,15 @@ class IndexedMonadTransPQ pq where => pq schema1 schema2 m y -> pq schema0 schema1 m x -> pq schema0 schema2 m y + pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) + + -- | indexed analog of `<=<` + pqAndThen + :: Monad m + => (y -> pq schema1 schema2 m z) + -> (x -> pq schema0 schema1 m y) + -> x -> pq schema0 schema2 m z + pqAndThen g f x = pqBind g (f x) -- | Safely embed a computation in a larger schema. pqEmbed @@ -253,14 +258,10 @@ instance IndexedMonadTransPQ PQ where K x' <- x (K (unK conn)) return $ K (f' x') - pqJoin pq = pq & pqBind id - pqBind f (PQ x) = PQ $ \ conn -> do K x' <- x conn unPQ (f x') (K (unK conn)) - pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) - pqEmbed (PQ pq) = PQ $ \ (K conn) -> do K x <- pq (K conn) return $ K x @@ -394,7 +395,8 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema) let toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary) params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params)) - resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary + q' = q <> ";" + resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary case resultMaybe of Nothing -> error "manipulateParams: LibPQ.execParams returned no results" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs index 92104c97..42584aca 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs @@ -9,8 +9,7 @@ A `MonadPQ` for pooled connections. -} {-# LANGUAGE - DataKinds - , DeriveFunctor + DeriveFunctor , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses @@ -43,7 +42,7 @@ import Squeal.PostgreSQL.PQ import Squeal.PostgreSQL.Schema -- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@. -newtype PoolPQ (schema :: TablesType) m x = +newtype PoolPQ (schema :: SchemaType) m x = PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x } deriving Functor @@ -110,7 +109,7 @@ instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where (_ :: K () schema) <- flip unPQ conn $ traversePrepared_ manipulation params return () - liftPQ m = PoolPQ $ \ pool -> + liftPQ m = PoolPQ $ \ pool -> withResource pool $ \ conn -> do (K result :: K result schema) <- flip unPQ conn $ liftPQ m diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 8639d922..247094f7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -9,23 +9,15 @@ Squeal queries. -} {-# LANGUAGE - DataKinds - , DeriveDataTypeable - , DeriveGeneric + DeriveGeneric , FlexibleContexts - , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving - , KindSignatures , LambdaCase - , MultiParamTypeClasses , OverloadedStrings - , ScopedTypeVariables , StandaloneDeriving - , TypeApplications , TypeInType , TypeOperators - , UndecidableInstances #-} module Squeal.PostgreSQL.Query @@ -44,6 +36,8 @@ module Squeal.PostgreSQL.Query , selectDistinctStar , selectDotStar , selectDistinctDotStar + , values + , values_ -- * Table Expressions , TableExpression (..) , renderTableExpression @@ -58,6 +52,7 @@ module Squeal.PostgreSQL.Query , FromClause (..) , table , subquery + , view , crossJoin , innerJoin , leftOuterJoin @@ -100,111 +95,111 @@ simple query: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] - query = selectStar (from (table (#tab `As` #t))) -in renderQuery query + query = selectStar (from (table #tab)) +in printSQL query :} -"SELECT * FROM \"tab\" AS \"t\"" +SELECT * FROM "tab" AS "tab" restricted query: >>> :{ let query :: Query - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "sum" ::: 'NotNull 'PGint4 , "col1" ::: 'NotNull 'PGint4 ] - query = + query = select - ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil) - ( from (table (#tab `As` #t)) + ((#col1 + #col2) `As` #sum :* #col1 :* Nil) + ( from (table #tab) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) ) -in renderQuery query +in printSQL query :} -"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"t\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))" +SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0)) subquery: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectStar - (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub))) -in renderQuery query + (from (subquery (selectStar (from (table #tab)) `As` #sub))) +in printSQL query :} -"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\"" +SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub" limits and offsets: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectStar - (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2) -in renderQuery query + (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2) +in printSQL query :} -"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4" +SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4 parameterized query: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])] '[ 'NotNull 'PGfloat8] '["col" ::: 'NotNull 'PGfloat8] query = selectStar - (from (table (#tab `As` #t)) & where_ (#col .> param @1)) -in renderQuery query + (from (table #tab) & where_ (#col .> param @1)) +in printSQL query :} -"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))" +SELECT * FROM "tab" AS "tab" WHERE ("col" > ($1 :: float8)) aggregation query: >>> :{ let query :: Query - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "sum" ::: 'NotNull 'PGint4 , "col1" ::: 'NotNull 'PGint4 ] query = - select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil) + select (sum_ #col2 `As` #sum :* #col1 :* Nil) ( from (table (#tab `As` #table1)) - & group (By #col1 :* Nil) + & group (By #col1 :* Nil) & having (#col1 + sum_ #col2 .> 1) ) -in renderQuery query +in printSQL query :} -"SELECT sum(\"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"table1\" GROUP BY \"col1\" HAVING ((\"col1\" + sum(\"col2\")) > 1)" +SELECT sum("col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum("col2")) > 1) sorted query: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectStar - (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst]) -in renderQuery query + (from (table #tab) & orderBy [#col & AscNullsFirst]) +in printSQL query :} -"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST" +SELECT * FROM "tab" AS "tab" ORDER BY "col" ASC NULLS FIRST joins: @@ -212,7 +207,7 @@ joins: >>> :{ let query :: Query - '[ "orders" ::: + '[ "orders" ::: 'Table ( '["pk_orders" ::: PrimaryKey '["id"] ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"] ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=> @@ -220,17 +215,17 @@ let , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4 , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4 , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 - ] - , "customers" ::: + ]) + , "customers" ::: 'Table ( '["pk_customers" ::: PrimaryKey '["id"]] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] - , "shippers" ::: + ]) + , "shippers" ::: 'Table ( '["pk_shippers" ::: PrimaryKey '["id"]] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] + ]) ] '[] '[ "order_price" ::: 'NotNull 'PGfloat4 @@ -246,49 +241,50 @@ let (#o ! #customer_id .== #c ! #id) & innerJoin (table (#shippers `As` #s)) (#o ! #shipper_id .== #s ! #id)) ) -in renderQuery query +in printSQL query :} -"SELECT \"o\".\"price\" AS \"order_price\", \"c\".\"name\" AS \"customer_name\", \"s\".\"name\" AS \"shipper_name\" 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\")" +SELECT "o"."price" AS "order_price", "c"."name" AS "customer_name", "s"."name" AS "shipper_name" 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 query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectDotStar #t1 (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2)))) -in renderQuery query +in printSQL query :} -"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\"" +SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2" set operations: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = - selectStar (from (table (#tab `As` #t))) + selectStar (from (table #tab)) `unionAll` - selectStar (from (table (#tab `As` #t))) -in renderQuery query + selectStar (from (table #tab)) +in printSQL query :} -"(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")" +(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab") -} newtype Query - (schema :: TablesType) + (schema :: SchemaType) (params :: [NullityType]) (columns :: RelationType) = UnsafeQuery { renderQuery :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Query schema params columns) where renderSQL = renderQuery -- | The results of two queries can be combined using the set operation --- `union`. Duplicate rows are eliminated. +-- `union`. Duplicate rows are eliminated. union :: Query schema params columns -> Query schema params columns @@ -364,7 +360,7 @@ SELECT queries -- the intermediate table are actually output. select :: SListI columns - => NP (Aliased (Expression relations grouping params)) (column ': columns) + => NP (Aliased (Expression schema relations grouping params)) (column ': columns) -- ^ select list -> TableExpression schema params relations grouping -- ^ intermediate virtual table @@ -378,7 +374,7 @@ select list rels = UnsafeQuery $ -- be subject to the elimination of duplicate rows using `selectDistinct`. selectDistinct :: SListI columns - => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns) + => NP (Aliased (Expression schema relations 'Ungrouped params)) (column ': columns) -- ^ select list -> TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table @@ -419,7 +415,7 @@ selectDotStar selectDotStar rel relations = UnsafeQuery $ "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations --- | A `selectDistinctDotStar` asks for all the columns of a particular table, +-- | A `selectDistinctDotStar` asks for all the columns of a particular table, -- and eliminates duplicate rows. selectDistinctDotStar :: Has relation relations columns @@ -432,6 +428,45 @@ selectDistinctDotStar rel relations = UnsafeQuery $ "SELECT DISTINCT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations +-- | `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 :* Nil) [] :: Query '[] '[] Row +-- >>> printSQL query +-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b") +values + :: SListI cols + => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols + -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols] + -- ^ When more than one row is specified, all the rows must + -- must have the same number of elements + -> Query schema 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 schema '[] 'Ungrouped params) ty -> ByteString + renderAliasPart (_ `As` name) = renderAlias name + renderValuePart (value `As` _) = renderExpression value + +-- | `values_` computes a row value or set of row values +-- specified by value expressions. +values_ + :: SListI cols + => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols + -- ^ one row of values + -> Query schema params cols +values_ rw = values rw [] + {----------------------------------------- Table Expressions -----------------------------------------} @@ -443,7 +478,7 @@ Table Expressions -- 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 - (schema :: TablesType) + (schema :: SchemaType) (params :: [NullityType]) (relations :: RelationsType) (grouping :: Grouping) @@ -451,7 +486,7 @@ data TableExpression { fromClause :: FromClause schema params relations -- ^ 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 relations 'Ungrouped params] + , whereClause :: [Condition schema relations 'Ungrouped params] -- ^ 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 @@ -467,13 +502,13 @@ data TableExpression -- 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 relations grouping params + , havingClause :: HavingClause schema relations grouping params -- ^ 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 relations grouping params] + , orderByClause :: [SortExpression schema relations grouping params] -- ^ 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. @@ -532,7 +567,7 @@ from rels = TableExpression rels [] NoGroups NoHaving [] [] [] -- | A `where_` is an endomorphism of `TableExpression`s which adds a -- search condition to the `whereClause`. where_ - :: Condition relations 'Ungrouped params -- ^ filtering condition + :: Condition schema relations 'Ungrouped params -- ^ filtering condition -> TableExpression schema params relations grouping -> TableExpression schema params relations grouping where_ wh rels = rels {whereClause = wh : whereClause rels} @@ -543,7 +578,7 @@ where_ wh rels = rels {whereClause = wh : whereClause rels} group :: SListI bys => NP (By relations) bys -- ^ grouped columns - -> TableExpression schema params relations 'Ungrouped + -> TableExpression schema params relations 'Ungrouped -> TableExpression schema params relations ('Grouped bys) group bys rels = TableExpression { fromClause = fromClause rels @@ -558,7 +593,7 @@ group bys rels = TableExpression -- | A `having` is an endomorphism of `TableExpression`s which adds a -- search condition to the `havingClause`. having - :: Condition relations ('Grouped bys) params -- ^ having condition + :: Condition schema relations ('Grouped bys) params -- ^ having condition -> TableExpression schema params relations ('Grouped bys) -> TableExpression schema params relations ('Grouped bys) having hv rels = rels @@ -567,7 +602,7 @@ having hv rels = rels -- | An `orderBy` is an endomorphism of `TableExpression`s which appends an -- ordering to the right of the `orderByClause`. orderBy - :: [SortExpression relations grouping params] -- ^ sort expressions + :: [SortExpression schema relations grouping params] -- ^ sort expressions -> TableExpression schema params relations grouping -> TableExpression schema params relations grouping orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts} @@ -602,16 +637,26 @@ newtype FromClause schema params relations -- | A real `table` is a table from the schema. table - :: Aliased (Table schema) table - -> FromClause schema params '[table] -table = UnsafeFromClause . renderAliasedAs renderTable + :: Has tab schema ('Table table) + => Aliased Alias (alias ::: tab) + -> FromClause schema params '[alias ::: TableToRelation table] +table (tab `As` alias) = UnsafeFromClause $ + renderAlias tab <+> "AS" <+> renderAlias alias -- | `subquery` derives a table from a `Query`. subquery - :: Aliased (Query schema params) table - -> FromClause schema params '[table] + :: Aliased (Query schema params) rel + -> FromClause schema params '[rel] subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery) +-- | `view` derives a table from a `View`. +view + :: Has view schema ('View rel) + => Aliased Alias (alias ::: view) + -> FromClause schema params '[alias ::: rel] +view (vw `As` alias) = UnsafeFromClause $ + renderAlias vw <+> "AS" <+> renderAlias alias + {- | @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@. @@ -633,7 +678,7 @@ the @on@ condition. innerJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -650,7 +695,7 @@ innerJoin right on left = UnsafeFromClause $ leftOuterJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -668,7 +713,7 @@ leftOuterJoin right on left = UnsafeFromClause $ rightOuterJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -687,7 +732,7 @@ rightOuterJoin right on left = UnsafeFromClause $ fullOuterJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -751,17 +796,17 @@ renderGroupByClause = \case -- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped` -- `TableExpression` must use `Having` whose conditions are combined with -- `.&&`. -data HavingClause relations grouping params where - NoHaving :: HavingClause relations 'Ungrouped params +data HavingClause schema relations grouping params where + NoHaving :: HavingClause schema relations 'Ungrouped params Having - :: [Condition relations ('Grouped bys) params] - -> HavingClause relations ('Grouped bys) params -deriving instance Show (HavingClause relations grouping params) -deriving instance Eq (HavingClause relations grouping params) -deriving instance Ord (HavingClause relations grouping params) + :: [Condition schema relations ('Grouped bys) params] + -> HavingClause schema relations ('Grouped bys) params +deriving instance Show (HavingClause schema relations grouping params) +deriving instance Eq (HavingClause schema relations grouping params) +deriving instance Ord (HavingClause schema relations grouping params) -- | Render a `HavingClause`. -renderHavingClause :: HavingClause relations grouping params -> ByteString +renderHavingClause :: HavingClause schema relations grouping params -> ByteString renderHavingClause = \case NoHaving -> "" Having [] -> "" @@ -780,29 +825,29 @@ Sorting -- `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 relations grouping params where +data SortExpression schema relations grouping params where Asc - :: Expression relations grouping params ('NotNull ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('NotNull ty) + -> SortExpression schema relations grouping params Desc - :: Expression relations grouping params ('NotNull ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('NotNull ty) + -> SortExpression schema relations grouping params AscNullsFirst - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params AscNullsLast - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params DescNullsFirst - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params DescNullsLast - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params -deriving instance Show (SortExpression relations grouping params) + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params +deriving instance Show (SortExpression schema relations grouping params) -- | Render a `SortExpression`. -renderSortExpression :: SortExpression relations grouping params -> ByteString +renderSortExpression :: SortExpression schema relations grouping params -> ByteString renderSortExpression = \case Asc expression -> renderExpression expression <+> "ASC" Desc expression -> renderExpression expression <+> "DESC" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs index d334f1b2..4b6beacb 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs @@ -9,12 +9,12 @@ Rendering helper functions. -} {-# LANGUAGE - MagicHash + FlexibleContexts + , MagicHash , OverloadedStrings , PolyKinds , RankNTypes , ScopedTypeVariables - , TypeApplications #-} module Squeal.PostgreSQL.Render @@ -26,8 +26,11 @@ module Squeal.PostgreSQL.Render , renderCommaSeparated , renderCommaSeparatedMaybe , renderNat + , RenderSQL (..) + , printSQL ) where +import Control.Monad.Base import Data.ByteString (ByteString) import Data.Maybe import Data.Monoid ((<>)) @@ -36,6 +39,7 @@ import GHC.Exts import GHC.TypeLits import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 -- | Parenthesize a `ByteString`. parenthesized :: ByteString -> ByteString @@ -78,3 +82,11 @@ renderCommaSeparatedMaybe render -- | Render a promoted `Nat`. renderNat :: KnownNat n => proxy n -> ByteString renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n))) + +-- | A class for rendering SQL +class RenderSQL sql where + renderSQL :: sql -> ByteString + +-- | Print SQL. +printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io () +printSQL = liftBase . Char8.putStrLn . renderSQL diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index c3ab8286..6e04ffad 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -5,32 +5,31 @@ Copyright: (c) Eitan Chatav, 2017 Maintainer: eitan@morphism.tech Stability: experimental -A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. +This module provides a type-level DSL for kinds of Postgres types, +tables, schema, constraints, aliases, enumerated labels, and groupings. +It also defines useful type families to operate on these. Finally, +it defines an embedding of Haskell types into Postgres types. -} {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds - , DataKinds , DeriveAnyClass - , DeriveDataTypeable , DeriveGeneric , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs - , MagicHash - , MultiParamTypeClasses , OverloadedStrings - , PolyKinds , RankNTypes , ScopedTypeVariables , StandaloneDeriving , TypeApplications - , TypeFamilies + , TypeFamilyDependencies , TypeInType , TypeOperators , UndecidableInstances + , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Schema @@ -39,35 +38,47 @@ module Squeal.PostgreSQL.Schema , HasOid (..) , NullityType (..) , ColumnType + -- * Tables , ColumnsType , RelationType , NilRelation , RelationsType , TableType - , TablesType - , NilTables - -- * Grouping - , Grouping (..) - , GroupedBy + -- * Schema + , SchemumType (..) + , SchemaType -- * Constraints , (:=>) , ColumnConstraint (..) , TableConstraint (..) , TableConstraints , NilTableConstraints + , Uniquely -- * Aliases , (:::) , Alias (Alias) , renderAlias + , renderAliases , Aliased (As) , renderAliasedAs , AliasesOf + , ZipAliased (..) , Has , HasUnique + , HasAll , IsLabel (..) , IsQualified (..) + -- * Enumerated Labels + , IsPGlabel (..) + , PGlabel (..) + , renderLabel + , renderLabels + -- * Grouping + , Grouping (..) + , GroupedBy -- * Type Families , Join + , With , Create , Drop , Alter @@ -79,35 +90,58 @@ module Squeal.PostgreSQL.Schema , PGFloating , PGTypeOf , SameTypes + , SamePGType , AllNotNull , NotAllNull , NullifyType , NullifyRelation , NullifyRelations , ColumnsToRelation - , RelationToColumns , TableToColumns - , TablesToRelations - , RelationsToTables + , TableToRelation , ConstraintInvolves , DropIfConstraintsInvolve - -- * Generics - , SameField - , SameFields + -- * Embedding + , PG + , EnumFrom + , LabelsFrom + , CompositeFrom + , FieldNamesFrom + , FieldTypesFrom + , ConstructorsOf + , ConstructorNameOf + , ConstructorNamesOf + , FieldsOf + , FieldNameOf + , FieldNamesOf + , FieldTypeOf + , FieldTypesOf + , RecordCodeOf + , MapMaybes (..) + , Nulls ) where import Control.DeepSeq -import Data.ByteString -import Data.Monoid +import Data.Aeson (Value) +import Data.ByteString (ByteString) +import Data.Int (Int16, Int32, Int64) +import Data.Kind +import Data.Monoid hiding (All) +import Data.Scientific (Scientific) import Data.String -import Data.Word +import Data.Text (Text) +import Data.Time +import Data.Word (Word16, Word32, Word64) import Data.Type.Bool -import Generics.SOP (AllZip) -import GHC.Generics (Generic) -import GHC.Exts +import Data.UUID.Types (UUID) +import Generics.SOP import GHC.OverloadedLabels import GHC.TypeLits +import Network.IP.Addr +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Text.Lazy as Lazy +import qualified GHC.Generics as GHC import qualified Generics.SOP.Type.Metadata as Type import Squeal.PostgreSQL.Render @@ -141,6 +175,8 @@ data PGType | PGjsonb -- ^ binary JSON data, decomposed | PGvararray PGType -- ^ variable length array | PGfixarray Nat PGType -- ^ fixed length array + | PGenum [Symbol] + | PGcomposite [(Symbol, PGType)] | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types -- | The object identifier of a `PGType`. @@ -190,10 +226,7 @@ type (:=>) constraint ty = '(constraint,ty) infixr 7 :=> -- | The alias operator `:::` is like a promoted version of `As`, --- a type level pair between --- an alias and some type, like a column alias and either a `ColumnType` or --- `NullityType` or a table alias and either a `TableType` or a `RelationType` --- or a constraint alias and a `TableConstraint`. +-- a type level pair between an alias and some type. type (:::) (alias :: Symbol) ty = '(alias,ty) infixr 6 ::: @@ -244,6 +277,15 @@ type TableConstraints = [(Symbol,TableConstraint)] type family NilTableConstraints :: TableConstraints where NilTableConstraints = '[] +-- | 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. -- @@ -257,31 +299,6 @@ type family NilTableConstraints :: TableConstraints where -- :} type TableType = (TableConstraints,ColumnsType) --- | `TablesType` is a row of `TableType`s, thought of as a union. --- --- >>> :{ --- type family Schema :: TablesType where --- Schema = --- '[ "users" ::: --- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2) --- ] --- , "emails" ::: --- '[ "pk_emails" ::: 'PrimaryKey '["id"] --- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] --- ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 --- , "email" ::: 'NoDef :=> 'Null 'PGtext --- ] --- ] --- :} -type TablesType = [(Symbol,TableType)] --- | A monokinded empty `TablesType`. -type family NilTables :: TablesType where NilTables = '[] - -- | `RelationType` is a row of `NullityType` -- -- >>> :{ @@ -305,27 +322,13 @@ type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where ColumnsToRelation (column ::: constraint :=> ty ': columns) = column ::: ty ': ColumnsToRelation columns --- | `RelationToColumns` adds `'NoDef` column constraints. -type family RelationToColumns (relation :: RelationType) :: ColumnsType where - RelationToColumns '[] = '[] - RelationToColumns (column ::: ty ': columns) = - column ::: 'NoDef :=> ty ': RelationToColumns columns - -- | `TableToColumns` removes table constraints. type family TableToColumns (table :: TableType) :: ColumnsType where TableToColumns (constraints :=> columns) = columns --- | `TablesToRelations` removes both table and column constraints. -type family TablesToRelations (tables :: TablesType) :: RelationsType where - TablesToRelations '[] = '[] - TablesToRelations (alias ::: constraint :=> columns ': tables) = - alias ::: ColumnsToRelation columns ': TablesToRelations tables - --- | `RelationsToTables` adds both trivial table and column constraints. -type family RelationsToTables (tables :: RelationsType) :: TablesType where - RelationsToTables '[] = '[] - RelationsToTables (alias ::: columns ': relations) = - alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations +-- | Convert a table to a relation. +type family TableToRelation (table :: TableType) :: RelationType where + TableToRelation tab = ColumnsToRelation (TableToColumns tab) -- | `Grouping` is an auxiliary namespace, created by -- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used @@ -355,15 +358,26 @@ instance {-# OVERLAPPABLE #-} -- >>> #foobar :: Alias "foobar" -- Alias data Alias (alias :: Symbol) = Alias - deriving (Eq,Generic,Ord,Show,NFData) + 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 :* Nil +instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias -- | >>> renderAlias #jimbob -- "\"jimbob\"" renderAlias :: KnownSymbol alias => Alias alias -> ByteString renderAlias = doubleQuoted . fromString . symbolVal +-- | >>> import Generics.SOP (NP(..)) +-- >>> renderAliases (#jimbob :* #kandi :* Nil) +-- ["\"jimbob\"","\"kandi\""] +renderAliases + :: All KnownSymbol aliases => NP Alias aliases -> [ByteString] +renderAliases = hcollapse + . hcmap (Proxy @KnownSymbol) (K . renderAlias) + -- | The `As` operator is used to name an expression. `As` is like a demoted -- version of `:::`. -- @@ -381,6 +395,9 @@ 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 -- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just") -- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int) @@ -397,12 +414,43 @@ type family AliasesOf aliaseds where AliasesOf '[] = '[] AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys +-- | The `ZipAliased` class provides a type family for zipping +-- `Symbol` lists together with arbitrary lists of the same size, +-- with an associated type family `ZipAs`, together with +-- a method `zipAs` for zipping heterogeneous lists of `Alias`es +-- together with a heterogeneous list of expressions into +-- a heterogeneous list of `Aliased` expressions. +class + ( SListI (ZipAs ns xs) + , All KnownSymbol ns + ) => ZipAliased ns xs where + + type family ZipAs + (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs + + zipAs + :: NP Alias ns + -> NP expr xs + -> NP (Aliased expr) (ZipAs ns xs) + +instance ZipAliased '[] '[] where + type ZipAs '[] '[] = '[] + zipAs Nil Nil = Nil + +instance + ( KnownSymbol n + , ZipAliased ns xs + ) => ZipAliased (n ': ns) (x ': xs) where + type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs + zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs + -- | @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@. +-- @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 where @@ -411,6 +459,20 @@ instance {-# OVERLAPPING #-} KnownSymbol alias instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field) => Has alias (field' ': fields) field +-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer +-- a list of @subfields@. +class + ( 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. @@ -456,6 +518,13 @@ type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType) SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1) = (ty0 ~ ty1, SameTypes columns0 columns1) +-- | Equality constraint on the underlying `PGType` of two columns. +class SamePGType + (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where +instance ty0 ~ ty1 => SamePGType + (alias0 ::: def0 :=> nullity0 ty0) + (alias1 ::: def1 :=> nullity1 ty1) + -- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. type family AllNotNull (columns :: ColumnsType) :: Constraint where AllNotNull '[] = () @@ -497,6 +566,10 @@ type family Join xs ys where -- `Squeal.PostgreSQL.Definition.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 in use") Create alias y (x ': xs) = x ': Create alias y xs -- | @Drop alias xs@ removes the type associated with @alias@ in @xs@ @@ -506,12 +579,12 @@ type family Drop alias xs where Drop alias ((alias ::: x) ': xs) = xs Drop alias (x ': xs) = x ': Drop alias xs --- | @Alter alias xs x@ replaces the type associated with an @alias@ in @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 xs x where - Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs - Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1 +type family Alter alias x xs where + Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs + Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs -- type family AddConstraint constraint ty where -- AddConstraint constraint (constraints :=> ty) @@ -533,26 +606,25 @@ type family Rename alias0 alias1 xs where Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs --- | A `SameField` constraint is an equality constraint on a --- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair. -class SameField - (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where -instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty) - --- | A `SameFields` constraint proves that a --- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same --- field names as the column AliasesOf of a `ColumnsType`. -type family SameFields - (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType) - :: Constraint where - SameFields - ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields]) - columns - = AllZip SameField fields columns - SameFields - ('Type.Newtype _module _datatype ('Type.Record _constructor fields)) - columns - = AllZip SameField fields columns +-- | `MapMaybes` is used in the binary instances of composite types. +class MapMaybes xs where + type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs + maybes :: NP Maybe xs -> NP I (Maybes xs) + unMaybes :: NP I (Maybes xs) -> NP Maybe xs +instance MapMaybes '[] where + type Maybes '[] = '[] + maybes Nil = Nil + unMaybes Nil = Nil +instance MapMaybes xs => MapMaybes (x ': xs) where + type Maybes (x ': xs) = Maybe x ': Maybes xs + maybes (x :* xs) = I x :* maybes xs + unMaybes (I mx :* xs) = mx :* unMaybes xs + +-- | `Nulls` is used to construct a `Squeal.Postgresql.Expression.row` +-- of a composite type. +type family Nulls tys where + Nulls '[] = '[] + Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where @@ -569,3 +641,199 @@ type family DropIfConstraintsInvolve column constraints where = If (ConstraintInvolves column constraint) (DropIfConstraintsInvolve column constraints) (alias ::: constraint ': DropIfConstraintsInvolve column constraints) + +-- | A `SchemumType` is a user-defined type, either a `Table`, +-- `View` or `Typedef`. +data SchemumType + = Table TableType + | View RelationType + | Typedef PGType + +-- | The schema of a database consists of a list of aliased, +-- user-defined `SchemumType`s. +type SchemaType = [(Symbol,SchemumType)] + +-- | Used in `Squeal.Postgresql.Manipulation.with`. +type family With + (relations :: RelationsType) + (schema :: SchemaType) + :: SchemaType where + With '[] schema = schema + With (alias ::: rel ': rels) schema = + alias ::: 'View rel ': With rels 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 ~ label' + => IsPGlabel label (PGlabel label') where label = PGlabel +-- | A `PGlabel` unit type with an `IsPGlabel` instance +data PGlabel (label :: Symbol) = PGlabel +-- | Renders a label +renderLabel :: KnownSymbol label => proxy label -> ByteString +renderLabel (_ :: proxy label) = + "\'" <> fromString (symbolVal (Proxy @label)) <> "\'" +-- | Renders a list of labels +renderLabels + :: All KnownSymbol labels => NP PGlabel labels -> [ByteString] +renderLabels = hcollapse + . hcmap (Proxy @KnownSymbol) (K . renderLabel) + +-- | The `PG` type family embeds a subset of Haskell types +-- as Postgres basic types. +-- +-- >>> :kind! PG LocalTime +-- PG LocalTime :: PGType +-- = 'PGtimestamp +type family PG (hask :: Type) :: PGType where + PG Bool = 'PGbool + PG Int16 = 'PGint2 + PG Int32 = 'PGint4 + PG Int64 = 'PGint8 + PG Word16 = 'PGint2 + PG Word32 = 'PGint4 + PG Word64 = 'PGint8 + PG Scientific = 'PGnumeric + PG Float = 'PGfloat4 + PG Double = 'PGfloat8 + PG Char = 'PGchar 1 + PG Text = 'PGtext + PG Lazy.Text = 'PGtext + PG ByteString = 'PGbytea + PG Lazy.ByteString = 'PGbytea + PG LocalTime = 'PGtimestamp + PG UTCTime = 'PGtimestamptz + PG Day = 'PGdate + PG TimeOfDay = 'PGtime + PG (TimeOfDay, TimeZone) = 'PGtimetz + PG DiffTime = 'PGinterval + PG UUID = 'PGuuid + PG (NetAddr IP) = 'PGinet + PG Value = 'PGjson + PG ty = TypeError + ('Text "There is no Postgres basic type for " ':<>: 'ShowType ty) + +-- | The `EnumFrom` type family embeds Haskell enum types, ADTs with +-- nullary constructors, as Postgres enum types +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance Generic Schwarma +-- >>> instance HasDatatypeInfo Schwarma +-- >>> :kind! EnumFrom Schwarma +-- EnumFrom Schwarma :: PGType +-- = 'PGenum '["Beef", "Lamb", "Chicken"] +type family EnumFrom (hask :: Type) :: PGType where + EnumFrom hask = 'PGenum (LabelsFrom hask) + +-- | The `LabelsFrom` type family calculates the constructors of a +-- Haskell enum type. +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance Generic Schwarma +-- >>> instance HasDatatypeInfo Schwarma +-- >>> :kind! LabelsFrom Schwarma +-- LabelsFrom Schwarma :: [Type.ConstructorName] +-- = '["Beef", "Lamb", "Chicken"] +type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where + LabelsFrom hask = + ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask)) + +-- | The `CompositeFrom` type family embeds Haskell record types as +-- Postgres composite types, as long as the record fields +-- are `Maybe`s of Haskell types that can be embedded as basic types +-- with the `PG` type family. +-- +-- >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic +-- >>> instance Generic Row +-- >>> instance HasDatatypeInfo Row +-- >>> :kind! CompositeFrom Row +-- CompositeFrom Row :: PGType +-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)] +type family CompositeFrom (hask :: Type) :: PGType where + CompositeFrom hask = + 'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask)) + +-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic +-- >>> instance Generic Row +-- >>> instance HasDatatypeInfo Row +-- >>> :kind! FieldNamesFrom Row +-- FieldNamesFrom Row :: [Type.FieldName] +-- = '["a", "b"] +type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where + FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask)) + +-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic +-- >>> instance Generic Row +-- >>> instance HasDatatypeInfo Row +-- >>> :kind! FieldTypesFrom Row +-- FieldTypesFrom Row :: [PGType] +-- = '['PGint2, 'PGtimestamp] +type family FieldTypesFrom (hask :: Type) :: [PGType] where + FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask)) + +-- | Calculates constructors of a datatype. +type family ConstructorsOf (datatype :: Type.DatatypeInfo) + :: [Type.ConstructorInfo] where + ConstructorsOf ('Type.ADT _module _datatype constructors) = + constructors + ConstructorsOf ('Type.Newtype _module _datatype constructor) = + '[constructor] + +-- | Calculates the name of a nullary constructor, otherwise +-- generates a type error. +type family ConstructorNameOf (constructors :: 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 + +-- | Calculate the fields of a datatype. +type family FieldsOf (datatype :: Type.DatatypeInfo) + :: [Type.FieldInfo] where + FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) = + fields + FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) = + fields + +-- | Calculate the name of a field. +type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where + FieldNameOf ('Type.FieldInfo name) = name + +-- | Calculate the names of fields. +type family FieldNamesOf (fields :: [Type.FieldInfo]) + :: [Type.FieldName] where + FieldNamesOf '[] = '[] + FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields + +-- | >>> :kind! FieldTypeOf (Maybe Int16) +-- FieldTypeOf (Maybe Int16) :: PGType +-- = 'PGint2 +type family FieldTypeOf (maybe :: Type) where + FieldTypeOf (Maybe hask) = PG hask + FieldTypeOf ty = TypeError + ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty) + +-- | Calculate the types of fields. +type family FieldTypesOf (fields :: [Type]) where + FieldTypesOf '[] = '[] + FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields + +-- | Inspect the code of an algebraic datatype and ensure it's a product, +-- otherwise generate a type error +type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where + RecordCodeOf _hask '[tys] = tys + RecordCodeOf hask _tys = TypeError + ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs index ddda791a..bc689bcb 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs @@ -9,16 +9,9 @@ Squeal transaction control language. -} {-# LANGUAGE - DataKinds - , EmptyCase - , FlexibleContexts - , FlexibleInstances + FlexibleContexts , LambdaCase , OverloadedStrings - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeFamilies - , TypeInType #-} module Squeal.PostgreSQL.Transaction @@ -165,22 +158,22 @@ data IsolationLevel = Serializable -- ^ Dirty read is not possible. -- Nonrepeatable read is not possible. - -- Phantom 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. + -- Phantom read is not possible. -- Serialization anomaly is possible. | ReadCommitted -- ^ Dirty read is not possible. -- Nonrepeatable read is possible. - -- Phantom 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. + -- Phantom read is possible. -- Serialization anomaly is possible. deriving (Show, Eq) diff --git a/stack.yaml b/stack.yaml index 192e3d42..a78c9ce1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-11.1 +resolver: lts-11.15 packages: - squeal-postgresql