squeal-postgresql 0.1.1.4 → 0.2
raw patch · 21 files changed
+3031/−2047 lines, 21 filesdep +mmorphdep +resource-pooldep +uuid-typesdep −hspecdep −uuiddep ~aesondep ~basedep ~bytestring
Dependencies added: mmorph, resource-pool, uuid-types, vector
Dependencies removed: hspec, uuid
Dependency ranges changed: aeson, base, bytestring, deepseq, doctest, generics-sop, lifted-base, monad-control, mtl, network-ip, postgresql-binary, postgresql-libpq, scientific, text, time, transformers, transformers-base
Files
- README.md +162/−97
- exe/Example.hs +43/−36
- squeal-postgresql.cabal +35/−44
- src/Squeal/PostgreSQL.hs +137/−101
- src/Squeal/PostgreSQL/Binary.hs +46/−33
- src/Squeal/PostgreSQL/Definition.hs +269/−182
- src/Squeal/PostgreSQL/Expression.hs +398/−335
- src/Squeal/PostgreSQL/Manipulation.hs +331/−187
- src/Squeal/PostgreSQL/Migration.hs +318/−0
- src/Squeal/PostgreSQL/PQ.hs +222/−189
- src/Squeal/PostgreSQL/Pool.hs +133/−0
- src/Squeal/PostgreSQL/Prettyprint.hs +0/−67
- src/Squeal/PostgreSQL/Query.hs +280/−241
- src/Squeal/PostgreSQL/Render.hs +75/−0
- src/Squeal/PostgreSQL/Schema.hs +346/−101
- src/Squeal/PostgreSQL/Transaction.hs +232/−0
- test/DocTest.hs +4/−0
- test/Spec.hs +0/−1
- test/Squeal/PostgreSQL/DefinitionSpec.hs +0/−124
- test/Squeal/PostgreSQL/ManipulationSpec.hs +0/−128
- test/Squeal/PostgreSQL/QuerySpec.hs +0/−181
README.md view
@@ -2,7 +2,7 @@  -[](https://circleci.com/gh/echatav/squeal)+[](https://circleci.com/gh/morphismtech/squeal) [Github](https://github.com/morphismtech/squeal) @@ -17,148 +17,213 @@ ## usage Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!--First, we need some language extensions because Squeal uses modern GHC features.-+First, we need some language extensions because Squeal uses modern GHC+features. ```haskell-{-# LANGUAGE- DataKinds- , DeriveGeneric- , OverloadedLabels- , OverloadedStrings- , TypeApplications- , TypeOperators-#-}+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators ``` -Here comes the Main module and imports.+We'll need some imports. ```haskell-module Main (main) where--import Control.Monad.Base (liftBase)-import Data.Int (Int32)-import Data.Text (Text)--import Squeal.PostgreSQL+>>> 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. ```haskell-import qualified Generics.SOP as SOP-import qualified GHC.Generics as GHC+>>> 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. The schema consists of a type-level list of tables, a `:::` pairing of a type level string or `Symbol` and a list a columns, itself a `:::` pairing of a `Symbol` and a `ColumnType`. The `ColumnType` describes the PostgreSQL type of the column as well as whether or not it may contain `NULL` and whether or not inserts and updates can use a `DEFAULT`. For our schema, we'll define two tables, a users table and an emails table.+The first step is to define the schema of our database. This is where+we use `DataKinds` and `TypeOperators`. The schema consists of a type-level+list of tables, a `:::` pairing of a type level string or+`Symbol` and a list a columns, itself a `:::` pairing of a+`Symbol` and a `ColumnType`. The `ColumnType` describes the+PostgreSQL type of the column as well as whether or not it may contain+`NULL` and whether or not inserts and updates can use a `DEFAULT`. For our+schema, we'll define two tables, a users table and an emails table. ```haskell+>>> :{ type Schema =- '[ "users" :::- '[ "id" ::: 'Optional ('NotNull 'PGint4)- , "name" ::: 'Required ('NotNull 'PGtext)+ '[ "users" :::+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] , "emails" :::- '[ "id" ::: 'Optional ('NotNull 'PGint4)- , "user_id" ::: 'Required ('NotNull 'PGint4)- , "email" ::: 'Required ('Null 'PGtext)+ '[ "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 ] ]+:} ``` -Next, we'll write Definitions 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.+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. ```haskell-setup :: Definition '[] Schema-setup = - createTable #users- ( serial `As` #id :*- (text & notNull) `As` #name :* Nil )- [ primaryKey (Column #id :* Nil) ]- >>>- createTable #emails- ( serial `As` #id :*- (int & notNull) `As` #user_id :*- text `As` #email :* Nil )- [ primaryKey (Column #id :* Nil)- , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)- OnDeleteCascade OnUpdateCascade ]+>>> :{+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 )+:} ``` -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.+We can easily see the generated SQL is unsuprising looking. ```haskell-teardown :: Definition Schema '[]-teardown = dropTable #emails >>> dropTable #users+>>> 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 rs (id) ON DELETE CASCADE ON UPDATE CASCADE);" ``` -Next, we'll write `Manipulation`s to insert data into our two tables. A `Manipulation` is an `insertInto`, `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.+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. ```haskell-insertUser :: Manipulation Schema- '[ 'Required ('NotNull 'PGtext)]- '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]-insertUser = insertInto #users- ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )- OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))--insertEmail :: Manipulation Schema- '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]-insertEmail = insertInto #emails ( Values- ( def `As` #id :*- param @1 `As` #user_id :*- param @2 `As` #email :* Nil) [] )- OnConflictDoNothing (Returning Nil)+>>> :{+let+ teardown :: Definition Schema '[]+ teardown = dropTable #emails >>> dropTable #users+:}+>>> renderDefinition teardown+"DROP TABLE emails; DROP TABLE users;" ``` -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.+Next, we'll write `Manipulation`s to insert data into our two tables.+A `Manipulation` is a `insertInto`, `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. ```haskell-getUsers :: Query Schema '[]- '[ "userName" ::: 'Required ('NotNull 'PGtext)- , "userEmail" ::: 'Required ('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)) )+>>> :{+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 URNING id AS fromOnly;"+>>> renderManipulation insertEmail+"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)N CONFLICT DO NOTHING;" ``` -Now that we've defined the SQL side of things, we'll need a Haskell type for users. We give the type `Generic` and `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`.+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. ```haskell-data User = User { userName :: Text, userEmail :: Maybe Text }- deriving (Show, GHC.Generic)-instance SOP.Generic User-instance SOP.HasDatatypeInfo User+>>> :{+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 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`. +```haskell+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, .Generic)+>>> instance SOP.Generic User+>>> instance SOP.HasDatatypeInfo User+```+ Let's also create some users to add to the database. ```haskell-users :: [User]-users = - [ User "Alice" (Just "alice@gmail.com")- , User "Bob" Nothing- , User "Carole" (Just "carole@hotmail.com")- ]+>>> :{+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.+Now we can put together all the pieces into a program. The program+connects to the database, sets up the schema, inserts the user data+(using prepared statements as an optimization), queries the user+data and prints it out and finally closes the connection. We can thread+the changing schema information through by using the indexed `PQ` monad+transformer and when the schema doesn't change we can use `Monad` and+`MonadPQ` functionality. ```haskell-main :: IO ()-main = void $- withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $- define setup- & pqThen session- & thenDefine teardown- where- session = do- idResults <- traversePrepared insertUser (Only . userName <$> users)- ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))- usersResult <- runQuery getUsers- usersRows <- getRows usersResult- liftBase $ print (usersRows :: [User])+>>> :{+let+ session :: PQ Schema Schema IO ()+ session = do+ idResults <- traversePrepared insertUser (Only . userName <$> users)+ ids <- traverse (fmap fromOnly . getRow (RowNumber 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+ & thenDefine teardown+:}+[User {userName = "Alice", userEmail = Just "alice`gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just role`hotmail.com"}] ```
exe/Example.hs view
@@ -4,6 +4,7 @@ , FlexibleContexts , OverloadedLabels , OverloadedStrings+ , OverloadedLists , TypeApplications , TypeOperators #-}@@ -12,9 +13,10 @@ import Control.Monad (void) import Control.Monad.Base (liftBase, MonadBase)-import Data.Int (Int32)+import Data.Int (Int16, Int32) import Data.Monoid ((<>)) import Data.Text (Text)+import Data.Vector (Vector) import Squeal.PostgreSQL @@ -24,13 +26,18 @@ type Schema = '[ "users" :::- '[ "id" ::: 'Optional ('NotNull 'PGint4)- , "name" ::: 'Required ('NotNull 'PGtext)+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2) ] , "emails" :::- '[ "id" ::: 'Optional ('NotNull 'PGint4)- , "user_id" ::: 'Required ('NotNull 'PGint4)- , "email" ::: 'Required ('Null 'PGtext)+ '[ "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 ] ] @@ -38,61 +45,61 @@ setup = createTable #users ( serial `As` #id :*- (text & notNull) `As` #name :* Nil )- [ primaryKey (Column #id :* Nil) ]+ (text & notNull) `As` #name :*+ (vararray int2 & notNull) `As` #vec :* 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)- , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)- OnDeleteCascade OnUpdateCascade ]+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) teardown :: Definition Schema '[] teardown = dropTable #emails >>> dropTable #users -insertUser :: Manipulation Schema- '[ 'Required ('NotNull 'PGtext)]- '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]-insertUser = insertInto #users- ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray 'PGint2)]+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]+insertUser = insertRows #users+ (Default `As` #id :* Set (param @1) `As` #name :* Set (param @2) `As` #vec :* Nil) [] OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) -insertEmail :: Manipulation Schema- '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]-insertEmail = insertInto #emails ( Values- ( def `As` #id :*- param @1 `As` #user_id :*- param @2 `As` #email :* Nil) [] )+insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]+insertEmail = insertRows #emails+ ( Default `As` #id :*+ Set (param @1) `As` #user_id :*+ Set (param @2) `As` #email :* Nil ) [] OnConflictDoNothing (Returning Nil) getUsers :: Query Schema '[]- '[ "userName" ::: 'Required ('NotNull 'PGtext)- , "userEmail" ::: 'Required ('Null 'PGtext) ]+ '[ "userName" ::: 'NotNull 'PGtext+ , "userEmail" ::: 'Null 'PGtext+ , "userVec" ::: 'NotNull ('PGvararray 'PGint2)] getUsers = select- (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)- ( from (Table (#users `As` #u)- & InnerJoin (Table (#emails `As` #e))+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* #u ! #vec `As` #userVec :* Nil)+ ( from (table (#users `As` #u)+ & innerJoin (table (#emails `As` #e)) (#u ! #id .== #e ! #user_id)) ) -data User = User { userName :: Text, userEmail :: Maybe Text }+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) } deriving (Show, GHC.Generic) instance SOP.Generic User instance SOP.HasDatatypeInfo User users :: [User] users = - [ User "Alice" (Just "alice@gmail.com")- , User "Bob" Nothing- , User "Carole" (Just "carole@hotmail.com")+ [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]+ , User "Bob" Nothing [Just 2, Nothing]+ , User "Carole" (Just "carole@hotmail.com") [Just 3] ] session :: (MonadBase IO pq, MonadPQ Schema pq) => pq () session = do liftBase $ Char8.putStrLn "manipulating"- idResults <- traversePrepared insertUser (Only . userName <$> users)- ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults+ idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])+ ids <- traverse (fmap fromOnly . getRow 0) idResults traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) liftBase $ Char8.putStrLn "querying" usersResult <- runQuery getUsers@@ -114,8 +121,8 @@ finish connection3 main2 :: IO ()-main2 = void $- withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $+main2 =+ void . withConnection "host=localhost port=5432 dbname=exampledb" $ define setup & pqThen session- & thenDefine teardown+ & pqThen (define teardown)
squeal-postgresql.cabal view
@@ -1,5 +1,5 @@ name: squeal-postgresql-version: 0.1.1.4+version: 0.2 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal@@ -26,46 +26,36 @@ Squeal.PostgreSQL.Definition Squeal.PostgreSQL.Expression Squeal.PostgreSQL.Manipulation+ Squeal.PostgreSQL.Migration+ Squeal.PostgreSQL.Pool Squeal.PostgreSQL.PQ- Squeal.PostgreSQL.Prettyprint+ Squeal.PostgreSQL.Render Squeal.PostgreSQL.Query Squeal.PostgreSQL.Schema+ Squeal.PostgreSQL.Transaction default-language: Haskell2010 ghc-options: -Wall -fprint-explicit-kinds build-depends:- aeson >= 1.2.1.0 && < 2- , base >= 4.10.0.0 && < 5- , bytestring >= 0.10.8.2 && < 1- , deepseq >= 1.4.3.0 && < 2- , generics-sop >= 0.3.1.0 && < 1- , lifted-base >= 0.2.3.11 && < 1- , monad-control >= 1.0.2.2 && < 2- , mtl >= 2.2.1 && < 3- , network-ip >= 0.3.0.2 && < 1- , postgresql-binary >= 0.12.1 && < 1- , postgresql-libpq >= 0.9.3.1 && < 1- , scientific >= 0.3.5.1 && < 1- , text >= 1.2.2.2 && < 2- , time >= 1.8.0.2 && < 2- , transformers >= 0.5.2.0 && < 1- , transformers-base >= 0.4.4 && < 1- , uuid >= 1.3.13 && < 2--test-suite squeal-postgresql-spec- default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: test- ghc-options: -Wall- main-is: Spec.hs- other-modules:- Squeal.PostgreSQL.DefinitionSpec- Squeal.PostgreSQL.ManipulationSpec- Squeal.PostgreSQL.QuerySpec- build-depends:- base >= 4.10.0.0 && < 5- , generics-sop >= 0.3.1.0 && < 1- , hspec >= 2.4.4 && < 3- , squeal-postgresql+ aeson >= 1.2.4.0+ , base >= 4.10.1.0 && < 5+ , bytestring >= 0.10.8.2+ , deepseq >= 1.4.3.0+ , generics-sop >= 0.3.2.0+ , lifted-base >= 0.2.3.12+ , mmorph >= 1.1.1+ , monad-control >= 1.0.2.3+ , mtl >= 2.2.2+ , network-ip >= 0.3.0.2+ , postgresql-binary >= 0.12.1+ , postgresql-libpq >= 0.9.4.1+ , resource-pool >= 0.2.3.2+ , scientific >= 0.3.5.3+ , text >= 1.2.3.0+ , time >= 1.8.0.2+ , transformers >= 0.5.2.0+ , transformers-base >= 0.4.4+ , uuid-types >= 1.0.3+ , vector >= 0.12.0.1 test-suite squeal-postgresql-doctest default-language: Haskell2010@@ -74,8 +64,8 @@ ghc-options: -Wall main-is: DocTest.hs build-depends:- base >= 4.10.0.0 && < 5- , doctest >= 0.11.4 && < 1+ base >= 4.10.0.0+ , doctest >= 0.11.4 executable squeal-postgresql-example default-language: Haskell2010@@ -83,11 +73,12 @@ ghc-options: -Wall main-is: Example.hs build-depends:- base >= 4.10.0.0 && < 5- , bytestring >= 0.10.8.2 && < 1- , generics-sop >= 0.3.1.0 && < 1- , mtl >= 2.2.1 && < 3+ base >= 4.10.0.0+ , bytestring >= 0.10.8.2+ , generics-sop >= 0.3.1.0+ , mtl >= 2.2.1 , squeal-postgresql- , text >= 1.2.2.2 && < 2- , transformers >= 0.5.2.0 && < 1- , transformers-base >= 0.4.4 && < 1+ , text >= 1.2.2.2+ , transformers >= 0.5.2.0+ , transformers-base >= 0.4.4+ , vector >= 0.12.0.1
src/Squeal/PostgreSQL.hs view
@@ -4,56 +4,55 @@ -- Maintainer: eitan@morphism.tech -- Stability: experimental ----- Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!+-- 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. ----- > {-# LANGUAGE--- > DataKinds--- > , DeriveGeneric--- > , OverloadedLabels--- > , OverloadedStrings--- > , TypeApplications--- > , TypeOperators--- > #-}+-- >>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels+-- >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -- --- Here comes the @Main@ module and imports.+-- We'll need some imports. ----- > module Main (main) where--- > --- > import Control.Monad.Base (liftBase)--- > import Data.Int (Int32)--- > import Data.Text (Text)--- >--- > import Squeal.PostgreSQL+-- >>> 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+-- >>> 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@. The schema consists of a type-level--- list of tables, a `:::` pairing of a type level string or--- @Symbol@ and a list a columns, itself a `:::` pairing of a--- @Symbol@ and a `ColumnType`. The `ColumnType` describes the--- PostgreSQL type of the column as well as whether or not it may contain--- @NULL@ and whether or not inserts and updates can use a @DEFAULT@. For our--- schema, we'll define two tables, a users table and an emails table.+-- we use @DataKinds@ and @TypeOperators@. ----- > type Schema =--- > '[ "users" :::--- > '[ "id" ::: 'Optional ('NotNull 'PGint4)--- > , "name" ::: 'Required ('NotNull 'PGtext)--- > ]--- > , "emails" :::--- > '[ "id" ::: 'Optional ('NotNull 'PGint4)--- > , "user_id" ::: 'Required ('NotNull 'PGint4)--- > , "email" ::: 'Required ('Null 'PGtext)--- > ]--- > ]+-- >>> :{+-- 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@@ -61,31 +60,45 @@ -- `>>>`. Here and in the rest of our commands we make use of overloaded -- labels to refer to named tables and columns in our schema. ----- > setup :: Definition '[] Schema--- > setup = --- > createTable #users--- > ( serial `As` #id :*--- > (text & notNull) `As` #name :* Nil )--- > [ primaryKey (Column #id :* Nil) ]--- > >>>--- > createTable #emails--- > ( serial `As` #id :*--- > (int & notNull) `As` #user_id :*--- > text `As` #email :* Nil )--- > [ primaryKey (Column #id :* Nil)--- > , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)--- > OnDeleteCascade OnUpdateCascade ]+-- >>> :{+-- 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. ----- > teardown :: Definition Schema '[]--- > teardown = dropTable #emails >>> dropTable #users+-- >>> :{+-- 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 a `insertInto`, `update` or `deleteFrom` command and+-- 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@@@ -95,54 +108,70 @@ -- the emails table. Take a careful look at the type and definition of both -- of our inserts. ----- > insertUser :: Manipulation Schema--- > '[ 'Required ('NotNull 'PGtext)]--- > '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]--- > insertUser = insertInto #users--- > ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )--- > OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))--- > --- > insertEmail :: Manipulation Schema--- > '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]--- > insertEmail = insertInto #emails ( Values--- > ( def `As` #id :*--- > param @1 `As` #user_id :*--- > param @2 `As` #email :* Nil) [] )--- > OnConflictDoNothing (Returning Nil)+-- >>> :{+-- 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. ----- > getUsers :: Query Schema '[]--- > '[ "userName" ::: 'Required ('NotNull 'PGtext)--- > , "userEmail" ::: 'Required ('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)) )+-- >>> :{+-- 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+-- >>> 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. ----- > users :: [User]--- > users = --- > [ User "Alice" (Just "alice@gmail.com")--- > , User "Bob" Nothing--- > , User "Carole" (Just "carole@hotmail.com")--- > ]+-- >>> :{+-- 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@@ -151,21 +180,26 @@ -- 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.--- --- > main :: IO ()--- > main = void $--- > withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $--- > define setup--- > & pqThen session--- > & thenDefine teardown--- > where--- > session = do--- > idResults <- traversePrepared insertUser (Only . userName <$> users)--- > ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults--- > traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))--- > usersResult <- runQuery getUsers--- > usersRows <- getRows usersResult--- > liftBase $ print (usersRows :: [User])+--+-- >>> :{+-- 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 ( module Squeal.PostgreSQL.Binary@@ -175,6 +209,7 @@ , module Squeal.PostgreSQL.PQ , module Squeal.PostgreSQL.Query , module Squeal.PostgreSQL.Schema+ , module Squeal.PostgreSQL.Transaction ) where import Squeal.PostgreSQL.Binary@@ -184,3 +219,4 @@ import Squeal.PostgreSQL.PQ import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Transaction
src/Squeal/PostgreSQL/Binary.hs view
@@ -48,7 +48,8 @@ import Data.Kind import Data.Scientific import Data.Time-import Data.UUID+import Data.UUID.Types+import Data.Vector (Vector) import Data.Word import Generics.SOP import GHC.TypeLits@@ -58,6 +59,7 @@ import qualified Data.ByteString as Strict hiding (unpack) import qualified Data.Text.Lazy as Lazy import qualified Data.Text as Strict+import qualified Data.Vector as Vector import qualified GHC.Generics as GHC import qualified PostgreSQL.Binary.Decoding as Decoding import qualified PostgreSQL.Binary.Encoding as Encoding@@ -113,39 +115,43 @@ instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast+instance (HasOid pg, ToParam x pg)+ => ToParam (Vector (Maybe x)) ('PGvararray pg) where+ toParam = K . Encoding.nullableArray_vector+ (oid @pg) (unK . toParam @x @pg) -- | A `ToColumnParam` constraint lifts the `ToParam` encoding -- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should -- not define instances of `ToColumnParam`, just use the provided instances.-class ToColumnParam (x :: Type) (ty :: ColumnType) where- -- | >>> toColumnParam @Int16 @('Required ('NotNull 'PGint2)) 0+class ToColumnParam (x :: Type) (ty :: NullityType) where+ -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0 -- K (Just "\NUL\NUL") --- -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) (Just 0)+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0) -- K (Just "\NUL\NUL") --- -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) Nothing+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing -- K Nothing toColumnParam :: x -> K (Maybe Strict.ByteString) ty-instance ToParam x pg => ToColumnParam x (optionality ('NotNull pg)) where+instance ToParam x pg => ToColumnParam x ('NotNull pg) where toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg-instance ToParam x pg => ToColumnParam (Maybe x) (optionality ('Null pg)) where+instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg) -- | A `ToParams` constraint generically sequences the encodings of `Type`s -- of the fields of a tuple or record to a row of `ColumnType`s. You should -- not define instances of `ToParams`. Instead define `Generic` instances -- which in turn provide `ToParams` instances.-class SListI tys => ToParams (x :: Type) (tys :: [ColumnType]) where- -- | >>> type PGparams = '[ 'Required ('NotNull 'PGbool), 'Required ('Null 'PGint2)]- -- >>> toParams @(Bool, Maybe Int16) @PGparams (False, Just 0)- -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)+class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where+ -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]+ -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)+ -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil -- -- >>> :set -XDeriveGeneric- -- >>> data Hparams = Hparams { col1 :: Bool, col2 :: Maybe Int16} deriving GHC.Generic- -- >>> instance Generic Hparams- -- >>> toParams @Hparams @PGparams (Hparams False (Just 0))- -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)+ -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic+ -- >>> instance Generic Tuple+ -- >>> toParams @Tuple @Params (Tuple False (Just 0))+ -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil toParams :: x -> NP (K (Maybe Strict.ByteString)) tys instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys) => ToParams x tys where@@ -187,23 +193,31 @@ fromValue _ = Decoding.interval_int instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast+instance FromValue pg y => FromValue ('PGvararray pg) (Vector (Maybe y)) where+ fromValue _ = Decoding.array+ (Decoding.dimensionArray Vector.replicateM+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))+instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where+ fromValue _ = Decoding.array+ (Decoding.dimensionArray Vector.replicateM+ (Decoding.nullableValueArray (fromValue (Proxy @pg)))) -- | A `FromColumnValue` constraint lifts the `FromValue` parser -- to a decoding of a @(Symbol, ColumnType)@ 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,ColumnType)) (y :: Type) where+class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where -- | >>> :set -XTypeOperators -XOverloadedStrings -- >>> newtype Id = Id { getId :: Int16 } deriving Show -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue- -- >>> fromColumnValue @("col" ::: 'Required ('NotNull 'PGint2)) @Id (K (Just "\NUL\SOH"))+ -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH")) -- Id {getId = 1} --- -- >>> fromColumnValue @("col" ::: 'Required ('Null 'PGint2)) @(Maybe Id) (K (Just "\NUL\SOH"))+ -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH")) -- Just (Id {getId = 1}) fromColumnValue :: K (Maybe Strict.ByteString) colty -> y instance FromValue pg y- => FromColumnValue (column ::: ('Required ('NotNull pg))) y where+ => FromColumnValue (column ::: ('NotNull pg)) y where fromColumnValue = \case K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL" K (Just bytes) ->@@ -214,7 +228,7 @@ in either err id errOrValue instance FromValue pg y- => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where+ => FromColumnValue (column ::: ('Null pg)) (Maybe y) where fromColumnValue (K nullOrBytes) = either err id . Decoding.valueParser (fromValue @pg @y Proxy)@@ -223,21 +237,21 @@ err str = error $ "fromColumnValue: " ++ Strict.unpack str -- | A `FromRow` constraint generically sequences the parsings of the columns--- of a `ColumnsType` into the fields of a record `Type` provided they have+-- of a `RelationType` into the fields of a record `Type` provided they have -- the same field names. You should not define instances of `FromRow`. -- Instead define `Generic` and `HasDatatypeInfo` instances which in turn -- provide `FromRow` instances.-class SListI results => FromRow (results :: ColumnsType) y where+class SListI results => FromRow (results :: RelationType) y where -- | >>> :set -XOverloadedStrings -- >>> import Data.Text- -- >>> newtype Id = Id { getId :: Int16 } deriving Show- -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue- -- >>> data Hrow = Hrow { userId :: Id, userName :: Maybe Text } deriving (Show, GHC.Generic)- -- >>> instance Generic Hrow- -- >>> instance HasDatatypeInfo Hrow- -- >>> type PGrow = '["userId" ::: 'Required ('NotNull 'PGint2), "userName" ::: 'Required ('Null 'PGtext)]- -- >>> fromRow @PGrow @Hrow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)- -- Hrow {userId = Id {getId = 1}, userName = Just "bloodninja"}+ -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show+ -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue+ -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)+ -- >>> instance Generic UserRow+ -- >>> instance HasDatatypeInfo UserRow+ -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]+ -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)+ -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"} fromRow :: NP (K (Maybe Strict.ByteString)) results -> y instance ( SListI results@@ -252,11 +266,10 @@ -- `toParams` or decoding a single value with `fromRow`. -- -- >>> import Data.Text--- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))+-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo")) -- K (Just "foo") :* Nil ----- >>> type PGShortRow = '["fromOnly" ::: 'Required ('Null 'PGtext)]--- >>> fromRow @PGShortRow @(Only (Maybe Text)) (K (Just "bar") :* Nil)+-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil) -- Only {fromOnly = Just "bar"} newtype Only x = Only { fromOnly :: x } deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
src/Squeal/PostgreSQL/Definition.hs view
@@ -9,16 +9,22 @@ -} {-# LANGUAGE- DataKinds+ ConstraintKinds+ , DataKinds , DeriveDataTypeable , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving , KindSignatures , LambdaCase+ , MultiParamTypeClasses , OverloadedStrings , RankNTypes+ , ScopedTypeVariables , StandaloneDeriving+ , TypeApplications , TypeInType , TypeOperators #-}@@ -29,11 +35,14 @@ , (>>>) -- * Create , createTable- , TableConstraint (UnsafeTableConstraint, renderTableConstraint)+ , createTableIfNotExists+ , TableConstraintExpression (..)+ , Column (..) , check , unique , primaryKey , foreignKey+ , ForeignKeyed , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade) , renderOnDeleteClause , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)@@ -43,12 +52,11 @@ -- * Alter , alterTable , alterTableRename- , alterTableAddConstraint- , AlterColumns (UnsafeAlterColumns, renderAlterColumns)- , addColumnDefault- , addColumnNull+ , AlterTable (UnsafeAlterTable, renderAlterTable)+ , addConstraint+ , dropConstraint+ , AddColumn (addColumn) , dropColumn- , dropColumnCascade , renameColumn , alterColumn , AlterColumn (UnsafeAlterColumn, renderAlterColumn)@@ -70,7 +78,7 @@ import qualified GHC.Generics as GHC import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Schema {-----------------------------------------@@ -100,31 +108,77 @@ -- >>> :set -XOverloadedLabels -- >>> :{ -- renderDefinition $--- createTable #tab (int `As` #a :* real `As` #b :* Nil) []+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil -- :} -- "CREATE TABLE tab (a int, b real);" createTable- :: (KnownSymbol table, SOP.SListI columns)+ :: ( KnownSymbol table+ , columns ~ (col ': cols)+ , SOP.SListI columns+ , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add- -> NP (Aliased TypeExpression) (column ': columns)+ -> NP (Aliased TypeExpression) columns -- ^ the names and datatype of each column- -> [TableConstraint schema (column ': columns)]+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints -- ^ constraints that must hold for the table- -> Definition schema (Create table (column ': columns) schema)+ -> Definition schema (Create table (constraints :=> columns) schema) createTable table columns constraints = UnsafeDefinition $- "CREATE TABLE" <+> renderAlias table+ "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);"+createTableIfNotExists+ :: ( Has table schema (constraints :=> columns)+ , SOP.SListI columns+ , SOP.SListI constraints )+ => Alias table -- ^ the name of the table to add+ -> NP (Aliased TypeExpression) columns+ -- ^ the names and datatype of each column+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints+ -- ^ constraints that must hold for the table+ -> Definition schema schema+createTableIfNotExists table columns constraints = UnsafeDefinition $+ "CREATE TABLE IF NOT EXISTS"+ <+> renderCreation table columns constraints++-- helper function for `createTable` and `createTableIfNotExists`+renderCreation+ :: ( KnownSymbol table+ , SOP.SListI columns+ , SOP.SListI constraints )+ => Alias table -- ^ the name of the table to add+ -> NP (Aliased TypeExpression) columns+ -- ^ the names and datatype of each column+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints+ -- ^ constraints that must hold for the table+ -> ByteString+renderCreation table columns constraints = renderAlias table <+> parenthesized ( renderCommaSeparated renderColumnDef columns- <> renderConstraints constraints )+ <> ( case constraints of+ Nil -> ""+ _ -> ", " <>+ renderCommaSeparated renderConstraint constraints ) ) <> ";" where renderColumnDef :: Aliased TypeExpression x -> ByteString renderColumnDef (ty `As` column) = renderAlias column <+> renderTypeExpression ty- renderConstraints :: [TableConstraint schema columns] -> ByteString- renderConstraints = \case- [] -> ""- _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)+ renderConstraint+ :: Aliased (TableConstraintExpression schema columns) constraint+ -> ByteString+ renderConstraint (constraint `As` alias) =+ "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint -- | Data types are a way to limit the kind of data that can be stored in a -- table. For many applications, however, the constraint they provide is@@ -138,12 +192,28 @@ -- as you wish. If a user attempts to store data in a column that would -- violate a constraint, an error is raised. This applies -- even if the value came from the default value definition.-newtype TableConstraint+newtype TableConstraintExpression (schema :: TablesType) (columns :: ColumnsType)- = UnsafeTableConstraint { renderTableConstraint :: ByteString }+ (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.@@ -153,14 +223,15 @@ -- createTable #tab -- ( (int & notNull) `As` #a :* -- (int & notNull) `As` #b :* Nil )--- [ check (#a .> #b) ]+-- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) -- :}--- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CHECK ((a > b)));"+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CONSTRAINT inequality CHECK ((a > b)));" check- :: Condition '[table ::: columns] 'Ungrouped '[]+ :: NP (Column columns) subcolumns+ -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[] -- ^ condition to check- -> TableConstraint schema columns-check condition = UnsafeTableConstraint $+ -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns))+check _cols condition = UnsafeTableConstraintExpression $ "CHECK" <+> parenthesized (renderExpression condition) -- | A `unique` constraint ensure that the data contained in a column,@@ -171,15 +242,15 @@ -- createTable #tab -- ( int `As` #a :* -- int `As` #b :* Nil )--- [ unique (Column #a :* Column #b :* Nil) ]+-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil ) -- :}--- "CREATE TABLE tab (a int, b int, UNIQUE (a, b));"+-- "CREATE TABLE tab (a int, b int, CONSTRAINT uq_a_b UNIQUE (a, b));" unique :: SOP.SListI subcolumns => NP (Column columns) subcolumns -- ^ unique column or group of columns- -> TableConstraint schema columns-unique columns = UnsafeTableConstraint $+ -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns))+unique columns = UnsafeTableConstraintExpression $ "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns) -- | A `primaryKey` constraint indicates that a column, or group of columns,@@ -191,15 +262,15 @@ -- createTable #tab -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil )--- [ primaryKey (Column #id :* Nil) ]+-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil ) -- :}--- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"+-- "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- -> TableConstraint schema columns-primaryKey columns = UnsafeTableConstraint $+ -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns))+primaryKey columns = UnsafeTableConstraintExpression $ "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns) -- | A `foreignKey` specifies that the values in a column@@ -208,59 +279,72 @@ -- between two related tables. -- -- >>> :{--- let--- definition :: Definition '[]--- '[ "users" :::--- '[ "id" ::: 'Optional ('NotNull 'PGint4)--- , "username" ::: 'Required ('NotNull 'PGtext)+-- type Schema =+-- '[ "users" :::+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext -- ]--- , "emails" :::--- '[ "id" ::: 'Optional ('NotNull 'PGint4)--- , "userid" ::: 'Required ('NotNull 'PGint4)--- , "email" ::: 'Required ('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 -- ]--- ]--- definition =--- createTable #users--- (serial `As` #id :* (text & notNull) `As` #username :* Nil)--- [primaryKey (Column #id :* Nil)] >>>--- createTable #emails--- ( serial `As` #id :*--- (integer & notNull) `As` #userid :*--- (text & notNull) `As` #email :* Nil )--- [ primaryKey (Column #id :* Nil)--- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)--- OnDeleteCascade OnUpdateRestrict--- ]--- in renderDefinition definition+-- ] -- :}--- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"+--+-- >>> :{+-- 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);" foreignKey- :: ( HasTable reftable schema refcolumns- , SameTypes subcolumns refsubcolumns- , AllNotNull subcolumns- , SOP.SListI subcolumns- , SOP.SListI refsubcolumns)+ :: ForeignKeyed schema table reftable subcolumns refsubcolumns => NP (Column columns) subcolumns -- ^ column or columns in the table- -> Alias reftable+ -> Alias table -- ^ reference table- -> NP (Column refcolumns) refsubcolumns+ -> NP (Column (TableToColumns reftable)) refsubcolumns -- ^ reference column or columns in the reference table -> OnDeleteClause -- ^ what to do when reference is deleted -> OnUpdateClause -- ^ what to do when reference is updated- -> TableConstraint schema columns+ -> TableConstraintExpression schema columns+ ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns)) foreignKey columns reftable refcolumns onDelete onUpdate =- UnsafeTableConstraint $+ UnsafeTableConstraintExpression $ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns) <+> "REFERENCES" <+> renderAlias reftable <+> parenthesized (renderCommaSeparated renderColumn refcolumns) <+> renderOnDeleteClause onDelete <+> renderOnUpdateClause onUpdate --- | `OnDelete` indicates what to do with rows that reference a deleted row.+-- | 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 )++-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. data OnDeleteClause = OnDeleteNoAction -- ^ if any referencing rows still exist when the constraint is checked,@@ -279,7 +363,7 @@ OnDeleteRestrict -> "ON DELETE RESTRICT" OnDeleteCascade -> "ON DELETE CASCADE" --- | Analagous to `OnDelete` there is also `OnUpdate` which is invoked+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked -- when a referenced column is changed (updated). data OnUpdateClause = OnUpdateNoAction@@ -319,14 +403,14 @@ -- | `alterTable` changes the definition of a table from the schema. alterTable- :: HasTable table schema columns0- => Alias table -- ^ table to alter- -> AlterColumns columns0 columns1 -- ^ alteration to perform- -> Definition schema (Alter table schema columns1)+ :: 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 $ "ALTER TABLE" <+> renderAlias table- <+> renderAlterColumns alteration+ <+> renderAlterTable alteration <> ";" -- | `alterTableRename` changes the name of a table from the schema.@@ -342,79 +426,97 @@ "ALTER TABLE" <+> renderAlias table0 <+> "RENAME TO" <+> renderAlias table1 <> ";" --- | An `alterTableAddConstraint` adds a table constraint.------ >>> :{--- let--- definition :: Definition--- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]--- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]--- definition = alterTableAddConstraint #tab (check (#col .> 0))--- in renderDefinition definition--- :}--- "ALTER TABLE tab ADD CHECK ((col > 0));"-alterTableAddConstraint- :: HasTable table schema columns- => Alias table -- ^ table to constrain- -> TableConstraint schema columns -- ^ what constraint to add- -> Definition schema schema-alterTableAddConstraint table constraint = UnsafeDefinition $- "ALTER TABLE" <+> renderAlias table- <+> "ADD" <+> renderTableConstraint constraint <> ";"---- | An `AlterColumns` describes the alteration to perform on the columns+-- | An `AlterTable` describes the alteration to perform on the columns -- of a table.-newtype AlterColumns- (columns0 :: ColumnsType)- (columns1 :: ColumnsType) =- UnsafeAlterColumns {renderAlterColumns :: ByteString}+newtype AlterTable+ (schema :: TablesType)+ (table0 :: TableType)+ (table1 :: TableType) =+ UnsafeAlterTable {renderAlterTable :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) --- | An `addColumnDefault` adds a new `Optional` column. The new column is--- initially filled with whatever default value is given.+-- | An `addConstraint` adds a table constraint. -- -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]--- '["tab" :::--- '[ "col1" ::: 'Required ('Null 'PGint4)--- , "col2" ::: 'Optional ('Null 'PGtext) ]]--- definition = alterTable #tab--- (addColumnDefault #col2 (text & default_ "foo"))+-- '["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 -- :}--- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"-addColumnDefault- :: KnownSymbol column- => Alias column -- ^ column to add- -> TypeExpression ('Optional ty) -- ^ type of the new column- -> AlterColumns columns (Create column ('Optional ty) columns)-addColumnDefault column ty = UnsafeAlterColumns $- "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty+-- "ALTER TABLE tab ADD CONSTRAINT positive CHECK ((col > 0));"+addConstraint+ :: KnownSymbol alias+ => Alias alias+ -> TableConstraintExpression schema columns constraint+ -- ^ constraint to add+ -> AlterTable schema (constraints :=> columns)+ (Create alias constraint constraints :=> columns)+addConstraint alias constraint = UnsafeAlterTable $+ "ADD" <+> "CONSTRAINT" <+> renderAlias alias+ <+> renderTableConstraintExpression constraint --- | An `addColumnDefault` adds a new `Null` column. The new column is--- initially filled with @NULL@s.+-- | A `dropConstraint` drops a table constraint. -- -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]--- '["tab" :::--- '[ "col1" ::: 'Required ('Null 'PGint4)--- , "col2" ::: 'Required ('Null 'PGtext) ]]--- definition = alterTable #tab (addColumnNull #col2 text)+-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]+-- definition = alterTable #tab (dropConstraint #positive) -- in renderDefinition definition -- :}--- "ALTER TABLE tab ADD COLUMN col2 text;"-addColumnNull- :: KnownSymbol column- => Alias column -- ^ column to add- -> TypeExpression ('Required ('Null ty)) -- ^ type of the new column- -> AlterColumns columns (Create column ('Required ('Null ty)) columns)-addColumnNull column ty = UnsafeAlterColumns $- "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty+-- "ALTER TABLE tab DROP CONSTRAINT positive;"+dropConstraint+ :: KnownSymbol constraint+ => Alias constraint+ -- ^ constraint to drop+ -> AlterTable schema+ (constraints :=> columns)+ (Drop constraint constraints :=> columns)+dropConstraint constraint = UnsafeAlterTable $+ "DROP" <+> "CONSTRAINT" <+> renderAlias constraint +-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.+class AddColumn ty where+ -- | `addColumn` adds a new column, initially filled with whatever+ -- default value is given or with @NULL@.+ --+ -- >>> :{+ -- let+ -- definition :: Definition+ -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]+ -- '["tab" ::: '[] :=>+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ]]+ -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo"))+ -- in renderDefinition definition+ -- :}+ -- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"+ --+ -- >>> :{+ -- let+ -- definition :: Definition+ -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]+ -- '["tab" ::: '[] :=>+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]+ -- definition = alterTable #tab (addColumn #col2 text)+ -- in renderDefinition definition+ -- :}+ -- "ALTER TABLE tab ADD COLUMN col2 text;"+ addColumn+ :: KnownSymbol column+ => Alias column -- ^ column to add+ -> TypeExpression ty -- ^ type of the new column+ -> AlterTable schema (constraints :=> columns)+ (constraints :=> Create column ty columns)+ addColumn column ty = UnsafeAlterTable $+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)+ -- | A `dropColumn` removes a column. Whatever data was in the column -- disappears. Table constraints involving the column are dropped, too. -- However, if the column is referenced by a foreign key constraint of@@ -423,10 +525,10 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" :::--- '[ "col1" ::: 'Required ('Null 'PGint4)--- , "col2" ::: 'Required ('Null 'PGtext) ]]--- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '[] :=>+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]+-- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] -- definition = alterTable #tab (dropColumn #col2) -- in renderDefinition definition -- :}@@ -434,57 +536,40 @@ dropColumn :: KnownSymbol column => Alias column -- ^ column to remove- -> AlterColumns columns (Drop column columns)-dropColumn column = UnsafeAlterColumns $+ -> AlterTable schema+ (constraints :=> columns)+ (DropIfConstraintsInvolve column constraints :=> Drop column columns)+dropColumn column = UnsafeAlterTable $ "DROP COLUMN" <+> renderAlias column --- | Like `dropColumn` but authorizes dropping everything that depends--- on the column.------ >>> :{--- let--- definition :: Definition--- '["tab" :::--- '[ "col1" ::: 'Required ('Null 'PGint4)--- , "col2" ::: 'Required ('Null 'PGtext) ]]--- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]--- definition = alterTable #tab (dropColumnCascade #col2)--- in renderDefinition definition--- :}--- "ALTER TABLE tab DROP COLUMN col2 CASCADE;"-dropColumnCascade- :: KnownSymbol column- => Alias column -- ^ column to remove- -> AlterColumns columns (Drop column columns)-dropColumnCascade column = UnsafeAlterColumns $- "DROP COLUMN" <+> renderAlias column <+> "CASCADE"- -- | A `renameColumn` renames a column. -- -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["foo" ::: 'Required ('Null 'PGint4)]]--- '["tab" ::: '["bar" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]]+-- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]] -- definition = alterTable #tab (renameColumn #foo #bar) -- in renderDefinition definition -- :} -- "ALTER TABLE tab RENAME COLUMN foo TO bar;" renameColumn :: (KnownSymbol column0, KnownSymbol column1)- => Alias column0- -> Alias column1- -> AlterColumns columns (Rename column0 column1 columns)-renameColumn column0 column1 = UnsafeAlterColumns $+ => Alias column0 -- ^ column to rename+ -> Alias column1 -- ^ what to rename the column+ -> AlterTable schema (constraints :=> columns)+ (constraints :=> Rename column0 column1 columns)+renameColumn column0 column1 = UnsafeAlterTable $ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1 -- | An `alterColumn` alters a single column. alterColumn- :: (KnownSymbol column, HasColumn column columns ty0)+ :: (KnownSymbol column, Has column columns ty0) => Alias column -- ^ column to alter -> AlterColumn ty0 ty1 -- ^ alteration to perform- -> AlterColumns columns (Alter column columns ty1)-alterColumn column alteration = UnsafeAlterColumns $+ -> AlterTable schema (constraints :=> columns)+ (constraints :=> Alter column columns ty1)+alterColumn column alteration = UnsafeAlterTable $ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration -- | An `AlterColumn` describes the alteration to perform on a single column.@@ -494,20 +579,20 @@ -- | A `setDefault` sets a new default for a column. Note that this doesn't -- affect any existing rows in the table, it just changes the default for--- future `insertTable` and `updateTable` commands.+-- future insert and update commands. -- -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]--- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]] -- definition = alterTable #tab (alterColumn #col (setDefault 5)) -- in renderDefinition definition -- :} -- "ALTER TABLE tab ALTER COLUMN col SET DEFAULT 5;" setDefault- :: Expression '[] 'Ungrouped '[] ('Required ty) -- ^ default value to set- -> AlterColumn (optionality ty) ('Optional ty)+ :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set+ -> AlterColumn (constraint :=> ty) ('Def :=> ty) setDefault expression = UnsafeAlterColumn $ "SET DEFAULT" <+> renderExpression expression @@ -516,13 +601,13 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]--- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] -- definition = alterTable #tab (alterColumn #col dropDefault) -- in renderDefinition definition -- :} -- "ALTER TABLE tab ALTER COLUMN col DROP DEFAULT;"-dropDefault :: AlterColumn (optionality ty) ('Required ty)+dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty) dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- | A `setNotNull` adds a @NOT NULL@ constraint to a column.@@ -532,13 +617,14 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]--- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] -- definition = alterTable #tab (alterColumn #col setNotNull) -- in renderDefinition definition -- :} -- "ALTER TABLE tab ALTER COLUMN col SET NOT NULL;"-setNotNull :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))+setNotNull+ :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.@@ -546,13 +632,14 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]--- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] -- definition = alterTable #tab (alterColumn #col dropNotNull) -- in renderDefinition definition -- :} -- "ALTER TABLE tab ALTER COLUMN col DROP NOT NULL;"-dropNotNull :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))+dropNotNull+ :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- | An `alterType` converts a column to a different data type.@@ -562,8 +649,8 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]--- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGnumeric)]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]] -- definition = -- alterTable #tab (alterColumn #col (alterType (numeric & notNull))) -- in renderDefinition definition
src/Squeal/PostgreSQL/Expression.hs view
@@ -37,13 +37,6 @@ ( -- * Expression Expression (UnsafeExpression, renderExpression) , HasParameter (param)- , HasColumn (getColumn)- , Column (Column)- , renderColumn- , GroupedBy (getGroup1, getGroup2)- -- ** Default- , def- , unDef -- ** Null , null_ , unNull@@ -53,7 +46,9 @@ , isn'tNull , matchNull , nullIf- -- ** Functions+ -- ** Arrays+ , array+ -- ** Functions , unsafeBinaryOp , unsafeUnaryOp , unsafeFunction@@ -104,8 +99,7 @@ , max_, maxDistinct, min_, minDistinct -- * Tables , Table (UnsafeTable, renderTable)- , HasTable (getTable)- -- * TypeExpression+ -- * Types , TypeExpression (UnsafeTypeExpression, renderTypeExpression) , PGTyped (pgtype) , bool@@ -143,6 +137,8 @@ , inet , json , jsonb+ , vararray+ , fixarray , notNull , default_ -- * Re-export@@ -164,7 +160,7 @@ import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Schema {-----------------------------------------@@ -181,10 +177,10 @@ and other operations. -} newtype Expression- (tables :: TablesType)+ (relations :: RelationsType) (grouping :: Grouping)- (params :: [ColumnType])- (ty :: ColumnType)+ (params :: [NullityType])+ (ty :: NullityType) = UnsafeExpression { renderExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -196,123 +192,51 @@ separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -}-class (PGTyped (BaseType ty), KnownNat n)- => HasParameter (n :: Nat) params ty | n params -> ty where- param :: Expression tables grouping params ty+class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter+ (n :: Nat)+ (params :: [NullityType])+ (ty :: NullityType)+ | n params -> ty where+ param :: Expression relations grouping params ty param = UnsafeExpression $ parenthesized $ "$" <> renderNat (Proxy @n) <+> "::"- <+> renderTypeExpression (pgtype @(BaseType ty))-instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)+ <+> 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 -{- | A `HasColumn` constraint indicates an unqualified column reference.-`getColumn` can only be unambiguous when the `TableExpression` the column-references is unique, in which case the column may be referenced using-@-XOverloadedLabels@. Otherwise, combined with a `HasTable` constraint, the-qualified column reference operator `!` may be used.--}-class KnownSymbol column => HasColumn column columns ty- | column columns -> ty where- getColumn- :: HasUnique table tables columns- => Alias column- -> Expression tables 'Ungrouped params ty- getColumn column = UnsafeExpression $ renderAlias column-instance {-# OVERLAPPING #-} KnownSymbol column- => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)-instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)- => HasColumn column (ty' ': table) ty--instance (HasColumn column columns ty, HasUnique table tables columns)- => IsLabel column (Expression tables 'Ungrouped params ty) where- fromLabel = getColumn (Alias @column)--instance (HasTable table tables columns, HasColumn column columns ty)- => IsTableColumn table column (Expression tables 'Ungrouped params ty) where- table ! column = UnsafeExpression $- renderAlias table <> "." <> renderAlias column---- | A `Column` is a witness to a `HasColumn` constraint. It's used--- in `Squeel.PostgreSQL.Definition.unique` and other--- `Squeel.PostgreSQL.Definition.TableConstraint`s to witness a--- subcolumns relationship.-data Column- (columns :: ColumnsType)- (columnty :: (Symbol,ColumnType))- where- Column- :: HasColumn column columns ty- => Alias column- -> Column columns (column ::: ty)-deriving instance Show (Column columns columnty)-deriving instance Eq (Column columns columnty)-deriving instance Ord (Column columns columnty)---- | Render a `Column`.-renderColumn :: Column columns columnty -> ByteString-renderColumn (Column column) = renderAlias column+instance (HasUnique relation relations columns, Has column columns ty)+ => IsLabel column (Expression relations 'Ungrouped params ty) where+ fromLabel = UnsafeExpression $ renderAlias (Alias @column) -{- | A `GroupedBy` constraint indicates that a table qualified column is-a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,-may be called in an output `Expression` without aggregating.--}-class (KnownSymbol table, KnownSymbol column)- => GroupedBy table column bys where- getGroup1- :: (HasUnique table tables columns, HasColumn column columns ty)- => Alias column- -> Expression tables ('Grouped bys) params ty- getGroup1 column = UnsafeExpression $ renderAlias column- getGroup2- :: (HasTable table tables columns, HasColumn column columns ty)- => Alias table- -> Alias column- -> Expression tables ('Grouped bys) params ty- getGroup2 table column = UnsafeExpression $- renderAlias table <> "." <> renderAlias column-instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)- => GroupedBy table column ('(table,column) ': bys)-instance {-# OVERLAPPABLE #-}- ( KnownSymbol table- , KnownSymbol column- , GroupedBy table column bys- ) => GroupedBy table column (tabcol ': bys)+instance (Has relation relations columns, Has column columns ty)+ => IsQualified relation column (Expression relations 'Ungrouped params ty) where+ relation ! column = UnsafeExpression $+ renderAlias relation <> "." <> renderAlias column instance- ( HasUnique table tables columns- , HasColumn column columns ty- , GroupedBy table column bys+ ( HasUnique relation relations columns+ , Has column columns ty+ , GroupedBy relation column bys ) => IsLabel column- (Expression tables ('Grouped bys) params ty) where- fromLabel = getGroup1 (Alias @column)+ (Expression relations ('Grouped bys) params ty) where+ fromLabel = UnsafeExpression $ renderAlias (Alias @column) instance- ( HasTable table tables columns- , HasColumn column columns ty- , GroupedBy table column bys- ) => IsTableColumn table column- (Expression tables ('Grouped bys) params ty) where (!) = getGroup2---- | >>> renderExpression def--- "DEFAULT"-def :: Expression '[] 'Ungrouped params ('Optional (nullity ty))-def = UnsafeExpression "DEFAULT"---- | >>> renderExpression $ unDef false--- "FALSE"-unDef- :: Expression '[] 'Ungrouped params ('Required (nullity ty))- -- ^ not @DEFAULT@- -> Expression '[] 'Ungrouped params ('Optional (nullity ty))-unDef = UnsafeExpression . renderExpression+ ( Has relation relations columns+ , Has column columns ty+ , GroupedBy relation column bys+ ) => IsQualified relation column+ (Expression relations ('Grouped bys) params ty) where+ relation ! column = UnsafeExpression $+ renderAlias relation <> "." <> renderAlias column -- | analagous to `Nothing` -- -- >>> renderExpression $ null_ -- "NULL"-null_ :: Expression tables grouping params (optionality ('Null ty))+null_ :: Expression relations grouping params ('Null ty) null_ = UnsafeExpression "NULL" -- | analagous to `Just`@@ -320,9 +244,9 @@ -- >>> renderExpression $ unNull true -- "TRUE" unNull- :: Expression tables grouping params (optionality ('NotNull ty))+ :: Expression relations grouping params ('NotNull ty) -- ^ not @NULL@- -> Expression tables grouping params (optionality ('Null ty))+ -> Expression relations grouping params ('Null ty) unNull = UnsafeExpression . renderExpression -- | return the leftmost value which is not NULL@@ -330,40 +254,40 @@ -- >>> renderExpression $ coalesce [null_, unNull true] false -- "COALESCE(NULL, TRUE, FALSE)" coalesce- :: [Expression tables grouping params ('Required ('Null ty))]+ :: [Expression relations grouping params ('Null ty)] -- ^ @NULL@s may be present- -> Expression tables grouping params ('Required ('NotNull ty))+ -> Expression relations grouping params ('NotNull ty) -- ^ @NULL@ is absent- -> Expression tables grouping params ('Required ('NotNull ty))+ -> Expression relations grouping params ('NotNull ty) coalesce nullxs notNullx = UnsafeExpression $ "COALESCE" <> parenthesized (commaSeparated ((renderExpression <$> nullxs) <> [renderExpression notNullx])) --- | analagous to `fromMaybe` using @COALESCE@+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@ -- -- >>> renderExpression $ fromNull true null_ -- "COALESCE(NULL, TRUE)" fromNull- :: Expression tables grouping params ('Required ('NotNull ty))+ :: Expression relations grouping params ('NotNull ty) -- ^ what to convert @NULL@ to- -> Expression tables grouping params ('Required ('Null ty))- -> Expression tables grouping params ('Required ('NotNull ty))+ -> Expression relations grouping params ('Null ty)+ -> Expression relations grouping params ('NotNull ty) fromNull notNullx nullx = coalesce [nullx] notNullx -- | >>> renderExpression $ null_ & isNull -- "NULL IS NULL" isNull- :: Expression tables grouping params ('Required ('Null ty))+ :: Expression relations grouping params ('Null ty) -- ^ possibly @NULL@- -> Condition tables grouping params+ -> Condition relations grouping params isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL" -- | >>> renderExpression $ null_ & isn'tNull -- "NULL IS NOT NULL" isn'tNull- :: Expression tables grouping params ('Required ('Null ty))+ :: Expression relations grouping params ('Null ty) -- ^ possibly @NULL@- -> Condition tables grouping params+ -> Condition relations grouping params isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@@@ -371,13 +295,13 @@ -- >>> renderExpression $ matchNull true not_ null_ -- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END" matchNull- :: Expression tables grouping params ('Required nullty)+ :: Expression relations grouping params (nullty) -- ^ what to convert @NULL@ to- -> ( Expression tables grouping params ('Required ('NotNull ty))- -> Expression tables grouping params ('Required nullty) )+ -> ( Expression relations grouping params ('NotNull ty)+ -> Expression relations grouping params (nullty) ) -- ^ function to perform when @NULL@ is absent- -> Expression tables grouping params ('Required ('Null ty))- -> Expression tables grouping params ('Required nullty)+ -> Expression relations grouping params ('Null ty)+ -> Expression relations grouping params (nullty) matchNull y f x = ifThenElse (isNull x) y (f (UnsafeExpression (renderExpression x))) @@ -388,33 +312,47 @@ -- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1)) -- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)" nullIf- :: Expression tables grouping params ('Required ('NotNull ty))+ :: Expression relations grouping params ('NotNull ty) -- ^ @NULL@ is absent- -> Expression tables grouping params ('Required ('NotNull ty))+ -> Expression relations grouping params ('NotNull ty) -- ^ @NULL@ is absent- -> Expression tables grouping params ('Required ('Null ty))+ -> Expression 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]"+array+ :: [Expression relations grouping params ('Null ty)]+ -- ^ array elements+ -> Expression relations grouping params (nullity ('PGvararray ty))+array xs = UnsafeExpression $+ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"++instance Monoid+ (Expression relations grouping params (nullity ('PGvararray ty))) where+ mempty = array []+ mappend = unsafeBinaryOp "||"+ -- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1] -- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))" greatest- :: Expression tables grouping params ('Required nullty)+ :: Expression relations grouping params (nullty) -- ^ needs at least 1 argument- -> [Expression tables grouping params ('Required nullty)]+ -> [Expression relations grouping params (nullty)] -- ^ or more- -> Expression tables grouping params ('Required nullty)+ -> Expression relations grouping params (nullty) greatest x xs = UnsafeExpression $ "GREATEST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" -- | >>> renderExpression $ least currentTimestamp [null_] -- "LEAST(CURRENT_TIMESTAMP, NULL)" least- :: Expression tables grouping params ('Required nullty)+ :: Expression relations grouping params (nullty) -- ^ needs at least 1 argument- -> [Expression tables grouping params ('Required nullty)]+ -> [Expression relations grouping params (nullty)] -- ^ or more- -> Expression tables grouping params ('Required nullty)+ -> Expression relations grouping params (nullty) least x xs = UnsafeExpression $ "LEAST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" @@ -423,9 +361,9 @@ unsafeBinaryOp :: ByteString -- ^ operator- -> Expression tables grouping params ('Required ty0)- -> Expression tables grouping params ('Required ty1)- -> Expression tables grouping params ('Required ty2)+ -> Expression relations grouping params (ty0)+ -> Expression relations grouping params (ty1)+ -> Expression relations grouping params (ty2) unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ renderExpression x <+> op <+> renderExpression y @@ -434,8 +372,8 @@ unsafeUnaryOp :: ByteString -- ^ operator- -> Expression tables grouping params ('Required ty0)- -> Expression tables grouping params ('Required ty1)+ -> Expression relations grouping params (ty0)+ -> Expression relations grouping params (ty1) unsafeUnaryOp op x = UnsafeExpression $ parenthesized $ op <+> renderExpression x @@ -444,13 +382,13 @@ unsafeFunction :: ByteString -- ^ function- -> Expression tables grouping params ('Required xty)- -> Expression tables grouping params ('Required yty)+ -> Expression relations grouping params (xty)+ -> Expression relations grouping params (yty) unsafeFunction fun x = UnsafeExpression $ fun <> parenthesized (renderExpression x) instance PGNum ty- => Num (Expression tables grouping params ('Required (nullity ty))) where+ => Num (Expression relations grouping params (nullity ty)) where (+) = unsafeBinaryOp "+" (-) = unsafeBinaryOp "-" (*) = unsafeBinaryOp "*"@@ -462,12 +400,12 @@ . show instance (PGNum ty, PGFloating ty) => Fractional- (Expression tables grouping params ('Required (nullity ty))) where+ (Expression relations grouping params (nullity ty)) where (/) = unsafeBinaryOp "/" fromRational x = fromInteger (numerator x) / fromInteger (denominator x) instance (PGNum ty, PGFloating ty) => Floating- (Expression tables grouping params ('Required (nullity ty))) where+ (Expression relations grouping params (nullity ty)) where pi = UnsafeExpression "pi()" exp = unsafeFunction "exp" log = unsafeFunction "ln"@@ -488,15 +426,20 @@ acosh x = log (x + sqrt (x*x - 1)) atanh x = log ((1 + x) / (1 - x)) / 2 --- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ atan2_ pi 2+-- | >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGfloat4)+-- expression = atan2_ pi 2+-- in renderExpression expression+-- :} -- "atan2(pi(), 2)" atan2_ :: PGFloating float- => Expression tables grouping params ('Required (nullity float))+ => Expression relations grouping params (nullity float) -- ^ numerator- -> Expression tables grouping params ('Required (nullity float))+ -> Expression relations grouping params (nullity float) -- ^ denominator- -> Expression tables grouping params ('Required (nullity float))+ -> Expression relations grouping params (nullity float) atan2_ y x = UnsafeExpression $ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")" @@ -507,115 +450,147 @@ -- | >>> renderExpression $ true & cast int4 -- "(TRUE :: int4)" cast- :: TypeExpression ('Required ('Null ty1))+ :: TypeExpression ('NoDef :=> 'Null ty1) -- ^ type to cast as- -> Expression tables grouping params ('Required (nullity ty0))+ -> Expression relations grouping params (nullity ty0) -- ^ value to convert- -> Expression tables grouping params ('Required (nullity ty1))+ -> Expression relations grouping params (nullity ty1) cast ty x = UnsafeExpression $ parenthesized $ renderExpression x <+> "::" <+> renderTypeExpression ty -- | integer division, truncates the result ----- >>> renderExpression @_ @_ @_ @(_(_ 'PGint2)) $ 5 `quot_` 2+-- >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGint2)+-- expression = 5 `quot_` 2+-- in renderExpression expression+-- :} -- "(5 / 2)" quot_ :: PGIntegral int- => Expression tables grouping params ('Required (nullity int))+ => Expression relations grouping params (nullity int) -- ^ numerator- -> Expression tables grouping params ('Required (nullity int))+ -> Expression relations grouping params (nullity int) -- ^ denominator- -> Expression tables grouping params ('Required (nullity int))+ -> Expression relations grouping params (nullity int) quot_ = unsafeBinaryOp "/" -- | remainder upon integer division ----- >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ 5 `rem_` 2+-- >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGint2)+-- expression = 5 `rem_` 2+-- in renderExpression expression+-- :} -- "(5 % 2)" rem_ :: PGIntegral int- => Expression tables grouping params ('Required (nullity int))+ => Expression relations grouping params (nullity int) -- ^ numerator- -> Expression tables grouping params ('Required (nullity int))+ -> Expression relations grouping params (nullity int) -- ^ denominator- -> Expression tables grouping params ('Required (nullity int))+ -> Expression relations grouping params (nullity int) rem_ = unsafeBinaryOp "%" --- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ trunc pi+-- | >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGfloat4)+-- expression = trunc pi+-- in renderExpression expression+-- :} -- "trunc(pi())" trunc :: PGFloating frac- => Expression tables grouping params ('Required (nullity frac))+ => Expression relations grouping params (nullity frac) -- ^ fractional number- -> Expression tables grouping params ('Required (nullity frac))+ -> Expression relations grouping params (nullity frac) trunc = unsafeFunction "trunc" --- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ round_ pi+-- | >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGfloat4)+-- expression = round_ pi+-- in renderExpression expression+-- :} -- "round(pi())" round_ :: PGFloating frac- => Expression tables grouping params ('Required (nullity frac))+ => Expression relations grouping params (nullity frac) -- ^ fractional number- -> Expression tables grouping params ('Required (nullity frac))+ -> Expression relations grouping params (nullity frac) round_ = unsafeFunction "round" --- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ ceiling_ pi+-- | >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGfloat4)+-- expression = ceiling_ pi+-- in renderExpression expression+-- :} -- "ceiling(pi())" ceiling_ :: PGFloating frac- => Expression tables grouping params ('Required (nullity frac))+ => Expression relations grouping params (nullity frac) -- ^ fractional number- -> Expression tables grouping params ('Required (nullity frac))+ -> Expression 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@,+-- 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 tables grouping params =- Expression tables grouping params ('Required ('NotNull 'PGbool))+type Condition relations grouping params =+ Expression relations grouping params ('NotNull 'PGbool) -- | >>> renderExpression true -- "TRUE"-true :: Condition tables grouping params+true :: Condition relations grouping params true = UnsafeExpression "TRUE" -- | >>> renderExpression false -- "FALSE"-false :: Condition tables grouping params+false :: Condition relations grouping params false = UnsafeExpression "FALSE" -- | >>> renderExpression $ not_ true -- "(NOT TRUE)" not_- :: Condition tables grouping params- -> Condition tables grouping params+ :: Condition relations grouping params+ -> Condition relations grouping params not_ = unsafeUnaryOp "NOT" -- | >>> renderExpression $ true .&& false -- "(TRUE AND FALSE)" (.&&)- :: Condition tables grouping params- -> Condition tables grouping params- -> Condition tables grouping params+ :: Condition relations grouping params+ -> Condition relations grouping params+ -> Condition relations grouping params (.&&) = unsafeBinaryOp "AND" -- | >>> renderExpression $ true .|| false -- "(TRUE OR FALSE)" (.||)- :: Condition tables grouping params- -> Condition tables grouping params- -> Condition tables grouping params+ :: Condition relations grouping params+ -> Condition relations grouping params+ -> Condition relations grouping params (.||) = unsafeBinaryOp "OR" --- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ caseWhenThenElse [(true, 1), (false, 2)] 3+-- | >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGint2)+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3+-- in renderExpression expression+-- :} -- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END" caseWhenThenElse- :: [ ( Condition tables grouping params- , Expression tables grouping params ('Required ty)+ :: [ ( Condition relations grouping params+ , Expression relations grouping params (ty) ) ]- -> Expression tables grouping params ('Required ty)- -> Expression tables grouping params ('Required ty)+ -- ^ whens and thens+ -> Expression relations grouping params (ty)+ -- ^ else+ -> Expression relations grouping params (ty) caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat [ "CASE" , mconcat@@ -629,13 +604,18 @@ , " END" ] --- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ ifThenElse true 1 0+-- | >>> :{+-- let+-- expression :: Expression relations grouping params (nullity 'PGint2)+-- expression = ifThenElse true 1 0+-- in renderExpression expression+-- :} -- "CASE WHEN TRUE THEN 1 ELSE 0 END" ifThenElse- :: Condition tables grouping params- -> Expression tables grouping params ('Required ty)- -> Expression tables grouping params ('Required ty)- -> Expression tables grouping params ('Required ty)+ :: Condition relations grouping params+ -> Expression relations grouping params (ty) -- ^ then+ -> Expression relations grouping params (ty) -- ^ else+ -> Expression relations grouping params (ty) ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`@@ -644,85 +624,85 @@ -- >>> renderExpression $ unNull true .== null_ -- "(TRUE = NULL)" (.==)- :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs- -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs- -> Expression tables grouping params ('Required (nullity 'PGbool))+ :: Expression relations grouping params (nullity ty) -- ^ lhs+ -> Expression relations grouping params (nullity ty) -- ^ rhs+ -> Expression relations grouping params (nullity 'PGbool) (.==) = unsafeBinaryOp "=" infix 4 .== -- | >>> renderExpression $ unNull true ./= null_ -- "(TRUE <> NULL)" (./=)- :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs- -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs- -> Expression tables grouping params ('Required (nullity 'PGbool))+ :: Expression relations grouping params (nullity ty) -- ^ lhs+ -> Expression relations grouping params (nullity ty) -- ^ rhs+ -> Expression relations grouping params (nullity 'PGbool) (./=) = unsafeBinaryOp "<>" infix 4 ./= -- | >>> renderExpression $ unNull true .>= null_ -- "(TRUE >= NULL)" (.>=)- :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs- -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs- -> Expression tables grouping params ('Required (nullity 'PGbool))+ :: Expression relations grouping params (nullity ty) -- ^ lhs+ -> Expression relations grouping params (nullity ty) -- ^ rhs+ -> Expression relations grouping params (nullity 'PGbool) (.>=) = unsafeBinaryOp ">=" infix 4 .>= -- | >>> renderExpression $ unNull true .< null_ -- "(TRUE < NULL)" (.<)- :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs- -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs- -> Expression tables grouping params ('Required (nullity 'PGbool))+ :: Expression relations grouping params (nullity ty) -- ^ lhs+ -> Expression relations grouping params (nullity ty) -- ^ rhs+ -> Expression relations grouping params (nullity 'PGbool) (.<) = unsafeBinaryOp "<" infix 4 .< -- | >>> renderExpression $ unNull true .<= null_ -- "(TRUE <= NULL)" (.<=)- :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs- -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs- -> Expression tables grouping params ('Required (nullity 'PGbool))+ :: Expression relations grouping params (nullity ty) -- ^ lhs+ -> Expression relations grouping params (nullity ty) -- ^ rhs+ -> Expression relations grouping params (nullity 'PGbool) (.<=) = unsafeBinaryOp "<=" infix 4 .<= -- | >>> renderExpression $ unNull true .> null_ -- "(TRUE > NULL)" (.>)- :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs- -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs- -> Expression tables grouping params ('Required (nullity 'PGbool))+ :: Expression relations grouping params (nullity ty) -- ^ lhs+ -> Expression relations grouping params (nullity ty) -- ^ rhs+ -> Expression relations grouping params (nullity 'PGbool) (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> renderExpression $ currentDate+-- | >>> renderExpression currentDate -- "CURRENT_DATE" currentDate- :: Expression tables grouping params ('Required (nullity 'PGdate))+ :: Expression relations grouping params (nullity 'PGdate) currentDate = UnsafeExpression "CURRENT_DATE" --- | >>> renderExpression $ currentTime+-- | >>> renderExpression currentTime -- "CURRENT_TIME" currentTime- :: Expression tables grouping params ('Required (nullity 'PGtimetz))+ :: Expression relations grouping params (nullity 'PGtimetz) currentTime = UnsafeExpression "CURRENT_TIME" --- | >>> renderExpression $ currentTimestamp+-- | >>> renderExpression currentTimestamp -- "CURRENT_TIMESTAMP" currentTimestamp- :: Expression tables grouping params ('Required (nullity 'PGtimestamptz))+ :: Expression relations grouping params (nullity 'PGtimestamptz) currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP" --- | >>> renderExpression $ localTime+-- | >>> renderExpression localTime -- "LOCALTIME" localTime- :: Expression tables grouping params ('Required (nullity 'PGtime))+ :: Expression relations grouping params (nullity 'PGtime) localTime = UnsafeExpression "LOCALTIME" --- | >>> renderExpression $ localTimestamp+-- | >>> renderExpression localTimestamp -- "LOCALTIMESTAMP" localTimestamp- :: Expression tables grouping params ('Required (nullity 'PGtimestamp))+ :: Expression relations grouping params (nullity 'PGtimestamp) localTimestamp = UnsafeExpression "LOCALTIMESTAMP" {-----------------------------------------@@ -730,7 +710,7 @@ -----------------------------------------} instance IsString- (Expression tables grouping params ('Required (nullity 'PGtext))) where+ (Expression relations grouping params (nullity 'PGtext)) where fromString str = UnsafeExpression $ "E\'" <> fromString (escape =<< str) <> "\'" where@@ -746,32 +726,32 @@ c -> [c] instance Monoid- (Expression tables grouping params ('Required (nullity 'PGtext))) where+ (Expression relations grouping params (nullity 'PGtext)) where mempty = fromString "" mappend = unsafeBinaryOp "||" -- | >>> renderExpression $ lower "ARRRGGG" -- "lower(E'ARRRGGG')" lower- :: Expression tables grouping params ('Required (nullity 'PGtext))+ :: Expression relations grouping params (nullity 'PGtext) -- ^ string to lower case- -> Expression tables grouping params ('Required (nullity 'PGtext))+ -> Expression relations grouping params (nullity 'PGtext) lower = unsafeFunction "lower" -- | >>> renderExpression $ upper "eeee" -- "upper(E'eeee')" upper- :: Expression tables grouping params ('Required (nullity 'PGtext))+ :: Expression relations grouping params (nullity 'PGtext) -- ^ string to upper case- -> Expression tables grouping params ('Required (nullity 'PGtext))+ -> Expression relations grouping params (nullity 'PGtext) upper = unsafeFunction "upper" -- | >>> renderExpression $ charLength "four" -- "char_length(E'four')" charLength- :: Expression tables grouping params ('Required (nullity 'PGtext))+ :: Expression relations grouping params (nullity 'PGtext) -- ^ string to measure- -> Expression tables grouping params ('Required (nullity 'PGint4))+ -> Expression relations grouping params (nullity 'PGint4) charLength = unsafeFunction "char_length" -- | The `like` expression returns true if the @string@ matches@@ -784,11 +764,11 @@ -- >>> renderExpression $ "abc" `like` "a%" -- "(E'abc' LIKE E'a%')" like- :: Expression tables grouping params ('Required (nullity 'PGtext))+ :: Expression relations grouping params (nullity 'PGtext) -- ^ string- -> Expression tables grouping params ('Required (nullity 'PGtext))+ -> Expression relations grouping params (nullity 'PGtext) -- ^ pattern- -> Expression tables grouping params ('Required (nullity 'PGbool))+ -> Expression relations grouping params (nullity 'PGbool) like = unsafeBinaryOp "LIKE" {-----------------------------------------@@ -798,44 +778,54 @@ -- | escape hatch to define aggregate functions unsafeAggregate :: ByteString -- ^ aggregate function- -> Expression tables 'Ungrouped params ('Required xty)- -> Expression tables ('Grouped bys) params ('Required yty)+ -> Expression relations 'Ungrouped params (xty)+ -> Expression 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 tables 'Ungrouped params ('Required xty)- -> Expression tables ('Grouped bys) params ('Required yty)+ -> Expression relations 'Ungrouped params (xty)+ -> Expression relations ('Grouped bys) params (yty) unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat [fun, "(DISTINCT ", renderExpression x, ")"] --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sum_ #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)+-- expression = sum_ #col+-- in renderExpression expression+-- :} -- "sum(col)" sum_ :: PGNum ty- => Expression tables 'Ungrouped params ('Required (nullity ty))+ => Expression relations 'Ungrouped params (nullity ty) -- ^ what to sum- -> Expression tables ('Grouped bys) params ('Required (nullity ty))+ -> Expression relations ('Grouped bys) params (nullity ty) sum_ = unsafeAggregate "sum" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sumDistinct #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)+-- expression = sumDistinct #col+-- in renderExpression expression+-- :} -- "sum(DISTINCT col)" sumDistinct :: PGNum ty- => Expression tables 'Ungrouped params ('Required (nullity ty))+ => Expression relations 'Ungrouped params (nullity ty) -- ^ what to sum- -> Expression tables ('Grouped bys) params ('Required (nullity ty))+ -> Expression 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 tables 'Ungrouped params ('Required (nullity ty))+ :: Expression relations 'Ungrouped params (nullity ty) -- ^ what to average- -> Expression tables ('Grouped bys) params ('Required (nullity avg))+ -> Expression relations ('Grouped bys) params (nullity avg) avg = unsafeAggregate "avg" avgDistinct = unsafeAggregateDistinct "avg" instance PGAvg 'PGint2 'PGnumeric@@ -846,72 +836,112 @@ instance PGAvg 'PGfloat8 'PGfloat8 instance PGAvg 'PGinterval 'PGinterval --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAnd #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)+-- expression = bitAnd #col+-- in renderExpression expression+-- :} -- "bit_and(col)" bitAnd :: PGIntegral int- => Expression tables 'Ungrouped params ('Required (nullity int))+ => Expression relations 'Ungrouped params (nullity int) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity int))+ -> Expression relations ('Grouped bys) params (nullity int) bitAnd = unsafeAggregate "bit_and" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOr #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)+-- expression = bitOr #col+-- in renderExpression expression+-- :} -- "bit_or(col)" bitOr :: PGIntegral int- => Expression tables 'Ungrouped params ('Required (nullity int))+ => Expression relations 'Ungrouped params (nullity int) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity int))+ -> Expression relations ('Grouped bys) params (nullity int) bitOr = unsafeAggregate "bit_or" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAndDistinct #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)+-- expression = bitAndDistinct #col+-- in renderExpression expression+-- :} -- "bit_and(DISTINCT col)" bitAndDistinct :: PGIntegral int- => Expression tables 'Ungrouped params ('Required (nullity int))+ => Expression relations 'Ungrouped params (nullity int) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity int))+ -> Expression relations ('Grouped bys) params (nullity int) bitAndDistinct = unsafeAggregateDistinct "bit_and" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOrDistinct #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)+-- expression = bitOrDistinct #col+-- in renderExpression expression+-- :} -- "bit_or(DISTINCT col)" bitOrDistinct :: PGIntegral int- => Expression tables 'Ungrouped params ('Required (nullity int))+ => Expression relations 'Ungrouped params (nullity int) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity int))+ -> Expression relations ('Grouped bys) params (nullity int) bitOrDistinct = unsafeAggregateDistinct "bit_or" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAnd #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)+-- expression = boolAnd #col+-- in renderExpression expression+-- :} -- "bool_and(col)" boolAnd- :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ :: Expression relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+ -> Expression relations ('Grouped bys) params (nullity 'PGbool) boolAnd = unsafeAggregate "bool_and" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOr #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)+-- expression = boolOr #col+-- in renderExpression expression+-- :} -- "bool_or(col)" boolOr- :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ :: Expression relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+ -> Expression relations ('Grouped bys) params (nullity 'PGbool) boolOr = unsafeAggregate "bool_or" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAndDistinct #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)+-- expression = boolAndDistinct #col+-- in renderExpression expression+-- :} -- "bool_and(DISTINCT col)" boolAndDistinct- :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ :: Expression relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+ -> Expression relations ('Grouped bys) params (nullity 'PGbool) boolAndDistinct = unsafeAggregateDistinct "bool_and" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOrDistinct #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)+-- expression = boolOrDistinct #col+-- in renderExpression expression+-- :} -- "bool_or(DISTINCT col)" boolOrDistinct- :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ :: Expression relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+ -> Expression relations ('Grouped bys) params (nullity 'PGbool) boolOrDistinct = unsafeAggregateDistinct "bool_or" -- | A special aggregation that does not require an input@@ -919,50 +949,70 @@ -- >>> renderExpression countStar -- "count(*)" countStar- :: Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))+ :: Expression relations ('Grouped bys) params ('NotNull 'PGint8) countStar = UnsafeExpression $ "count(*)" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Optional _]] $ count #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)+-- expression = count #col+-- in renderExpression expression+-- :} -- "count(col)" count- :: Expression tables 'Ungrouped params ('Required ty)+ :: Expression relations 'Ungrouped params ty -- ^ what to count- -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8) count = unsafeAggregate "count" --- | >>> renderExpression @'[_ ::: '["col" ::: 'Required _]] $ countDistinct #col+-- | >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)+-- expression = countDistinct #col+-- in renderExpression expression+-- :} -- "count(DISTINCT col)" countDistinct- :: Expression tables 'Ungrouped params ('Required ty)+ :: Expression relations 'Ungrouped params ty -- ^ what to count- -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8) countDistinct = unsafeAggregateDistinct "count" -- | synonym for `boolAnd` ----- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ every #col+-- >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)+-- expression = every #col+-- in renderExpression expression+-- :} -- "every(col)" every- :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ :: Expression relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+ -> Expression relations ('Grouped bys) params (nullity 'PGbool) every = unsafeAggregate "every" -- | synonym for `boolAndDistinct` ----- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ everyDistinct #col+-- >>> :{+-- let+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)+-- expression = everyDistinct #col+-- in renderExpression expression+-- :} -- "every(DISTINCT col)" everyDistinct- :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ :: Expression relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+ -> Expression relations ('Grouped bys) params (nullity 'PGbool) everyDistinct = unsafeAggregateDistinct "every" -- | minimum and maximum aggregation max_, min_, maxDistinct, minDistinct- :: Expression tables 'Ungrouped params ('Required (nullity ty))+ :: Expression relations 'Ungrouped params (nullity ty) -- ^ what to aggregate- -> Expression tables ('Grouped bys) params ('Required (nullity ty))+ -> Expression relations ('Grouped bys) params (nullity ty) max_ = unsafeAggregate "max" min_ = unsafeAggregate "min" maxDistinct = unsafeAggregateDistinct "max"@@ -972,28 +1022,18 @@ tables -----------------------------------------} --- | A `Table` from a schema without its alias with an `IsLabel` instance+-- | A `Table` from a table expression is a way -- to call a table reference by its alias. newtype Table (schema :: TablesType)- (columns :: ColumnsType)+ (columns :: RelationType) = UnsafeTable { renderTable :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData)---- | A `HasTable` constraint indicates a table reference.-class KnownSymbol table => HasTable table tables columns- | table tables -> columns where- getTable :: Alias table -> Table tables columns- getTable table = UnsafeTable $ renderAlias table-instance {-# OVERLAPPING #-} KnownSymbol table- => HasTable table ((table ::: columns) ': tables) columns-instance {-# OVERLAPPABLE #-}- (KnownSymbol table, HasTable table schema columns)- => HasTable table (table' ': schema) columns--instance HasTable table schema columns- => IsLabel table (Table schema columns) where- fromLabel = getTable (Alias @table)+instance+ ( Has alias schema table+ , relation ~ ColumnsToRelation (TableToColumns table)+ ) => IsLabel alias (Table schema relation) where+ fromLabel = UnsafeTable $ renderAlias (Alias @alias) {----------------------------------------- type expressions@@ -1005,117 +1045,136 @@ deriving (GHC.Generic,Show,Eq,Ord,NFData) -- | logical Boolean (true/false)-bool :: TypeExpression ('Required ('Null 'PGbool))+bool :: TypeExpression ('NoDef :=> 'Null 'PGbool) bool = UnsafeTypeExpression "bool" -- | signed two-byte integer-int2, smallint :: TypeExpression ('Required ('Null 'PGint2))+int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2) int2 = UnsafeTypeExpression "int2" smallint = UnsafeTypeExpression "smallint" -- | signed four-byte integer-int4, int, integer :: TypeExpression ('Required ('Null 'PGint4))+int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4) int4 = UnsafeTypeExpression "int4" int = UnsafeTypeExpression "int" integer = UnsafeTypeExpression "integer" -- | signed eight-byte integer-int8, bigint :: TypeExpression ('Required ('Null 'PGint8))+int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8) int8 = UnsafeTypeExpression "int8" bigint = UnsafeTypeExpression "bigint" -- | arbitrary precision numeric type-numeric :: TypeExpression ('Required ('Null 'PGnumeric))+numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric) numeric = UnsafeTypeExpression "numeric" -- | single precision floating-point number (4 bytes)-float4, real :: TypeExpression ('Required ('Null 'PGfloat4))+float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4) float4 = UnsafeTypeExpression "float4" real = UnsafeTypeExpression "real" -- | double precision floating-point number (8 bytes)-float8, doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))+float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null '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 ('Optional ('NotNull '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 ('Optional ('NotNull '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 ('Optional ('NotNull 'PGint8))+serial8, bigserial+ :: TypeExpression ('Def :=> 'NotNull 'PGint8) serial8 = UnsafeTypeExpression "serial8" bigserial = UnsafeTypeExpression "bigserial" -- | variable-length character string-text :: TypeExpression ('Required ('Null 'PGtext))+text :: TypeExpression ('NoDef :=> 'Null 'PGtext) text = UnsafeTypeExpression "text" -- | fixed-length character string char, character :: (KnownNat n, 1 <= n) => proxy n- -> TypeExpression ('Required ('Null ('PGchar n)))+ -> TypeExpression ('NoDef :=> 'Null ('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 ('Required ('Null ('PGvarchar n)))+ -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n)) varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")" characterVarying p = UnsafeTypeExpression $ "character varying(" <> renderNat p <> ")" -- | binary data ("byte array")-bytea :: TypeExpression ('Required ('Null 'PGbytea))+bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea) bytea = UnsafeTypeExpression "bytea" -- | date and time (no time zone)-timestamp :: TypeExpression ('Required ('Null 'PGtimestamp))+timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp) timestamp = UnsafeTypeExpression "timestamp" -- | date and time, including time zone-timestampWithTimeZone :: TypeExpression ('Required ('Null 'PGtimestamptz))+timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz) timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone" -- | calendar date (year, month, day)-date :: TypeExpression ('Required ('Null 'PGdate))+date :: TypeExpression ('NoDef :=> 'Null 'PGdate) date = UnsafeTypeExpression "date" -- | time of day (no time zone)-time :: TypeExpression ('Required ('Null 'PGtime))+time :: TypeExpression ('NoDef :=> 'Null 'PGtime) time = UnsafeTypeExpression "time" -- | time of day, including time zone-timeWithTimeZone :: TypeExpression ('Required ('Null 'PGtimetz))+timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz) timeWithTimeZone = UnsafeTypeExpression "time with time zone" -- | time span-interval :: TypeExpression ('Required ('Null 'PGinterval))+interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval) interval = UnsafeTypeExpression "interval" -- | universally unique identifier-uuid :: TypeExpression ('Required ('Null 'PGuuid))+uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid) uuid = UnsafeTypeExpression "uuid" -- | IPv4 or IPv6 host address-inet :: TypeExpression ('Required ('Null 'PGinet))+inet :: TypeExpression ('NoDef :=> 'Null 'PGinet) inet = UnsafeTypeExpression "inet" -- | textual JSON data-json :: TypeExpression ('Required ('Null 'PGjson))+json :: TypeExpression ('NoDef :=> 'Null 'PGjson) json = UnsafeTypeExpression "json" -- | binary JSON data, decomposed-jsonb :: TypeExpression ('Required ('Null 'PGjsonb))+jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb) jsonb = UnsafeTypeExpression "jsonb"+-- | variable length array+vararray+ :: TypeExpression ('NoDef :=> 'Null pg)+ -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg))+vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"+-- | fixed length array+--+-- >>> renderTypeExpression (fixarray (Proxy @2) json)+-- "json[2]"+fixarray+ :: KnownNat n+ => proxy n+ -> TypeExpression ('NoDef :=> 'Null pg)+ -> TypeExpression ('NoDef :=> 'Null ('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 (optionality ('Null ty))- -> TypeExpression (optionality ('NotNull ty))+ :: 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 '[] ('Required ty)- -> TypeExpression ('Required ty)- -> TypeExpression ('Optional ty)+ :: 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 ('Required ('Null ty))+ pgtype :: TypeExpression ('NoDef :=> 'Null ty) instance PGTyped 'PGbool where pgtype = bool instance PGTyped 'PGint2 where pgtype = int2 instance PGTyped 'PGint4 where pgtype = int4@@ -1138,3 +1197,7 @@ 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)
src/Squeal/PostgreSQL/Manipulation.hs view
@@ -12,6 +12,7 @@ DataKinds , DeriveDataTypeable , DeriveGeneric+ , FlexibleContexts , GADTs , GeneralizedNewtypeDeriving , KindSignatures@@ -27,90 +28,72 @@ ( -- * Manipulation Manipulation (UnsafeManipulation, renderManipulation) , queryStatement- -- * Insert- , insertInto- , ValuesClause (Values, ValuesQuery)- , renderValuesClause+ , ColumnValue (..) , ReturningClause (ReturningStar, Returning)- , renderReturningClause , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)+ -- * Insert+ , insertRows+ , insertRow+ , insertRows_+ , insertRow_+ , insertQuery+ , insertQuery_+ , renderReturningClause , renderConflictClause -- * Update , update- , UpdateExpression (Same, Set)- , renderUpdateExpression+ , update_+ -- * Delete , deleteFrom+ , deleteFrom_+ -- * With+ , with ) where import Control.DeepSeq-import Data.ByteString+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 import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Schema --- | A `Manipulation` is a statement which may modify data in the database,--- but does not alter the schema. Examples are `insertInto`, `update` and--- `deleteFrom`. A `Query` is also considered a `Manipulation` even though--- it does not modify data.-newtype Manipulation- (schema :: TablesType)- (params :: [ColumnType])- (columns :: ColumnsType)- = UnsafeManipulation { renderManipulation :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)---- | Convert a `Query` into a `Manipulation`.-queryStatement- :: Query schema params columns- -> Manipulation schema params columns-queryStatement q = UnsafeManipulation $ renderQuery q <> ";"--{------------------------------------------INSERT statements------------------------------------------}- {- |-When a table is created, it contains no data. The first thing to do-before a database can be of much use is to insert data. Data is-conceptually inserted one row at a time. Of course you can also insert-more than one row, but there is no way to insert less than one row.-Even if you know only some column values, a complete row must be created.+A `Manipulation` is a statement which may modify data in the database,+but does not alter the schema. Examples are inserts, updates and deletes.+A `Query` is also considered a `Manipulation` even though it does not modify data. simple insert: >>> :{ let manipulation :: Manipulation- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[] manipulation =- insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])- OnConflictDoRaise (Returning Nil)+ insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) in renderManipulation manipulation :}-"INSERT INTO tab (col1, col2) VALUES (2, 4);"+"INSERT INTO tab (col1, col2) VALUES (2, DEFAULT);" parameterized insert: >>> :{ let manipulation :: Manipulation- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4) ]]- '[ 'Required ('NotNull 'PGint4)- , 'Required ('NotNull 'PGint4) ] '[]+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]+ '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[] manipulation =- insertInto #tab- (Values (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) [])- OnConflictDoRaise (Returning Nil)+ insertRow_ #tab+ (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil) in renderManipulation manipulation :} "INSERT INTO tab (col1, col2) VALUES (($1 :: int4), ($2 :: int4));"@@ -120,106 +103,223 @@ >>> :{ let manipulation :: Manipulation- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]- '["fromOnly" ::: 'Required ('NotNull 'PGint4)]+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[]+ '["fromOnly" ::: 'NotNull 'PGint4] manipulation =- insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])+ insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil)) in renderManipulation manipulation :}-"INSERT INTO tab (col1, col2) VALUES (2, 4) RETURNING col1 AS fromOnly;"+"INSERT INTO tab (col1, col2) VALUES (2, DEFAULT) RETURNING col1 AS fromOnly;" +upsert:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]+ '[] '[ "sum" ::: 'NotNull 'PGint4]+ manipulation =+ insertRows #tab+ (Set 2 `As` #col1 :* Set 4 `As` #col2 :* Nil)+ [Set 6 `As` #col1 :* Set 8 `As` #col2 :* Nil]+ (OnConflictDoUpdate+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+ [#col1 .== #col2])+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)+in renderManipulation 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;"+ query insert: >>> :{ let manipulation :: Manipulation- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4)+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]- , "other_tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4)+ , "other_tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ] ] '[] '[] manipulation = - insertInto #tab- ( ValuesQuery $- selectStar (from (Table (#other_tab `As` #t))) )- OnConflictDoRaise (Returning Nil)+ insertQuery_ #tab+ (selectStar (from (table (#other_tab `As` #t)))) in renderManipulation manipulation :} "INSERT INTO tab SELECT * FROM other_tab AS t;" -upsert:+update: >>> :{ let manipulation :: Manipulation- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4) ]]- '[] '[ "sum" ::: 'Required ('NotNull 'PGint4)]+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[] manipulation =- insertInto #tab- (Values- (2 `As` #col1 :* 4 `As` #col2 :* Nil)- [6 `As` #col1 :* 8 `As` #col2 :* Nil])- (OnConflictDoUpdate- (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)- (Just (#col1 .== #col2)))- (Returning $ (#col1 + #col2) `As` #sum :* Nil)+ update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+ (#col1 ./= #col2) in renderManipulation 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;"+"UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"++delete:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]+ '[ "col1" ::: 'NotNull 'PGint4+ , "col2" ::: 'NotNull 'PGint4 ]+ manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar+in renderManipulation manipulation+:}+"DELETE FROM tab WHERE (col1 = col2) RETURNING *;" -}-insertInto- :: (SOP.SListI columns, SOP.SListI results, HasTable table schema columns)- => Alias table -- ^ table to insert into- -> ValuesClause schema params columns -- ^ values to insert+newtype Manipulation+ (schema :: TablesType)+ (params :: [NullityType])+ (columns :: RelationType)+ = UnsafeManipulation { renderManipulation :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | Convert a `Query` into a `Manipulation`.+queryStatement+ :: Query schema params columns+ -> Manipulation schema params columns+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"++{-----------------------------------------+INSERT statements+-----------------------------------------}++-- | Insert multiple rows.+--+-- When a table is created, it contains no data. The first thing to do+-- before a database can be of much use is to insert data. Data is+-- conceptually inserted one row at a time. Of course you can also insert+-- more than one row, but there is no way to insert less than one row.+-- Even if you know only some column values, a complete row must be created.+insertRows+ :: ( SOP.SListI columns+ , SOP.SListI results+ , Has tab schema 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 -- ^ what to do in case of constraint conflict -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results-insertInto table insert conflict returning = UnsafeManipulation $- "INSERT" <+> "INTO" <+> renderAlias table- <+> renderValuesClause insert- <> renderConflictClause conflict- <> renderReturningClause returning---- | A `ValuesClause` lets you insert either values, free `Expression`s,--- or the result of a `Query`.-data ValuesClause- (schema :: TablesType)- (params :: [ColumnType])- (columns :: ColumnsType)- = Values- (NP (Aliased (Expression '[] 'Ungrouped params)) columns)- [NP (Aliased (Expression '[] 'Ungrouped params)) columns]- -- ^ at least one row of values- | ValuesQuery (Query schema params columns)---- | Render a `ValuesClause`.-renderValuesClause- :: SOP.SListI columns- => ValuesClause schema params columns- -> ByteString-renderValuesClause = \case- Values row rows ->- parenthesized (renderCommaSeparated renderAliasPart row)+insertRows tab row rows conflict returning = UnsafeManipulation $+ "INSERT" <+> "INTO" <+> renderAlias tab+ <+> parenthesized (renderCommaSeparated renderAliasPart row) <+> "VALUES" <+> commaSeparated- (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)+ ( parenthesized+ . renderCommaSeparated renderColumnValuePart <$> row:rows )+ <> renderConflictClause conflict+ <> renderReturningClause returning where- renderAliasPart, renderValuePart- :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString+ renderAliasPart, renderColumnValuePart+ :: Aliased (ColumnValue '[] params) ty -> ByteString renderAliasPart (_ `As` name) = renderAlias name- renderValuePart (value `As` _) = renderExpression value- ValuesQuery q -> renderQuery q+ renderColumnValuePart (value `As` _) = case value of+ Default -> "DEFAULT"+ Set expression -> renderExpression expression +-- | Insert a single row.+insertRow+ :: ( SOP.SListI columns+ , SOP.SListI results+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to insert into+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert+ -> ConflictClause columns params+ -- ^ what to do in case of constraint conflict+ -> ReturningClause columns params results -- ^ results to return+ -> Manipulation schema params results+insertRow tab row = insertRows tab row []++-- | Insert multiple rows returning `Nil` and raising an error on conflicts.+insertRows_+ :: ( SOP.SListI columns+ , Has tab schema 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+ -> Manipulation schema params '[]+insertRows_ tab row rows =+ insertRows tab row rows OnConflictDoRaise (Returning Nil)++-- | Insert a single row returning `Nil` and raising an error on conflicts.+insertRow_+ :: ( SOP.SListI columns+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to insert into+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert+ -> Manipulation schema params '[]+insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)++-- | Insert a `Query`.+insertQuery+ :: ( SOP.SListI columns+ , SOP.SListI results+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to insert into+ -> Query schema params (ColumnsToRelation columns)+ -> ConflictClause columns params+ -- ^ what to do in case of constraint conflict+ -> ReturningClause columns params results -- ^ results to return+ -> Manipulation schema params results+insertQuery tab query conflict returning = UnsafeManipulation $+ "INSERT" <+> "INTO" <+> renderAlias tab+ <+> renderQuery query+ <> renderConflictClause conflict+ <> renderReturningClause returning++-- | Insert a `Query` returning `Nil` and raising an error on conflicts.+insertQuery_+ :: ( SOP.SListI columns+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to insert into+ -> Query schema params (ColumnsToRelation columns)+ -> Manipulation schema params '[]+insertQuery_ tab query =+ insertQuery tab query OnConflictDoRaise (Returning Nil)++-- | `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.+data ColumnValue+ (columns :: RelationType)+ (params :: [NullityType])+ (ty :: ColumnType)+ where+ Same :: ColumnValue (column ': columns) params ty+ Default :: ColumnValue columns params ('Def :=> ty)+ Set+ :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)+ -> ColumnValue columns params (constraint :=> ty)+ -- | A `ReturningClause` computes and return value(s) based -- on each row actually inserted, updated or deleted. This is primarily -- useful for obtaining values that were supplied by defaults, such as a@@ -228,18 +328,19 @@ -- deleted will be returned. For example, if a row was locked -- but not updated because an `OnConflictDoUpdate` condition was not satisfied, -- the row will not be returned. `ReturningStar` will return all columns--- in the row. Use `Returning Nil` in the common case where no return+-- in the row. Use @Returning Nil@ in the common case where no return -- values are desired. data ReturningClause (columns :: ColumnsType)- (params :: [ColumnType])- (results :: ColumnsType)+ (params :: [NullityType])+ (results :: RelationType) where- ReturningStar :: ReturningClause columns params columns+ ReturningStar+ :: results ~ ColumnsToRelation columns+ => ReturningClause columns params results Returning- :: NP- (Aliased (Expression '[table ::: columns] 'Ungrouped params))- results+ :: rel ~ ColumnsToRelation columns+ => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results -> ReturningClause columns params results -- | Render a `ReturningClause`.@@ -251,19 +352,19 @@ ReturningStar -> " RETURNING *;" Returning Nil -> ";" Returning results -> " RETURNING"- <+> renderCommaSeparated (renderAliased 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 params where+data ConflictClause (columns :: ColumnsType) params where OnConflictDoRaise :: ConflictClause columns params OnConflictDoNothing :: ConflictClause columns params OnConflictDoUpdate- :: NP (Aliased (UpdateExpression columns params)) columns- -> Maybe (Condition '[table ::: columns] 'Ungrouped params)+ :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns+ -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params] -> ConflictClause columns params -- | Render a `ConflictClause`.@@ -274,12 +375,22 @@ renderConflictClause = \case OnConflictDoRaise -> "" OnConflictDoNothing -> " ON CONFLICT DO NOTHING"- OnConflictDoUpdate updates whMaybe+ OnConflictDoUpdate updates whs' -> " ON CONFLICT DO UPDATE SET"- <+> renderCommaSeparatedMaybe renderUpdateExpression updates- <> case whMaybe of- Nothing -> ""- Just wh -> " WHERE" <+> renderExpression wh+ <+> renderCommaSeparatedMaybe renderUpdate updates+ <> case whs' of+ [] -> ""+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)+ where+ renderUpdate+ :: Aliased (ColumnValue columns params) column+ -> Maybe ByteString+ renderUpdate = \case+ Same `As` _ -> Nothing+ Default `As` column -> Just $+ renderAlias column <+> "=" <+> "DEFAULT"+ Set expression `As` column -> Just $+ renderAlias column <+> "=" <+> renderExpression expression {----------------------------------------- UPDATE statements@@ -287,82 +398,115 @@ -- | An `update` command changes the values of the specified columns -- in all rows that satisfy the condition.------ >>> :{--- let--- manipulation :: Manipulation--- '[ "tab" :::--- '[ "col1" ::: 'Required ('NotNull 'PGint4)--- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]--- manipulation =--- update #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)--- (#col1 ./= #col2) (Returning Nil)--- in renderManipulation manipulation--- :}--- "UPDATE tab SET col1 = 2 WHERE (col1 <> col2);" update- :: (HasTable table schema columns, SOP.SListI columns, SOP.SListI results)- => Alias table -- ^ table to update- -> NP (Aliased (UpdateExpression columns params)) columns+ :: ( SOP.SListI columns+ , SOP.SListI results+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to update+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values- -> Condition '[tab ::: columns] 'Ungrouped params+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to perform update on a row -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results-update table columns wh returning = UnsafeManipulation $+update tab columns wh returning = UnsafeManipulation $ "UPDATE"- <+> renderAlias table+ <+> renderAlias tab <+> "SET"- <+> renderCommaSeparatedMaybe renderUpdateExpression columns+ <+> renderCommaSeparatedMaybe renderUpdate columns <+> "WHERE" <+> renderExpression wh <> renderReturningClause returning---- | Columns to be updated are mentioned with `Set`; columns which are to--- remain the same are mentioned with `Same`.-data UpdateExpression columns params ty- = Same- -- ^ column to remain the same upon update- | Set (forall table. Expression '[table ::: columns] 'Ungrouped params ty)- -- ^ column to be updated-deriving instance Show (UpdateExpression columns params ty)-deriving instance Eq (UpdateExpression columns params ty)-deriving instance Ord (UpdateExpression columns params ty)+ where+ renderUpdate+ :: Aliased (ColumnValue columns params) column+ -> Maybe ByteString+ renderUpdate = \case+ Same `As` _ -> Nothing+ Default `As` column -> Just $+ renderAlias column <+> "=" <+> "DEFAULT"+ Set expression `As` column -> Just $+ renderAlias column <+> "=" <+> renderExpression expression --- | Render an `UpdateExpression`.-renderUpdateExpression- :: Aliased (UpdateExpression params columns) column- -> Maybe ByteString-renderUpdateExpression = \case- Same `As` _ -> Nothing- Set expression `As` column -> Just $- renderAlias column <+> "=" <+> renderExpression expression+-- | Update a row returning `Nil`.+update_+ :: ( SOP.SListI columns+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to update+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns+ -- ^ modified values to replace old values+ -> Condition '[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) {----------------------------------------- DELETE statements -----------------------------------------} -- | Delete rows of a table.------ >>> :{--- let--- manipulation :: Manipulation--- '[ "tab" :::--- '[ "col1" ::: 'Required ('NotNull 'PGint4)--- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]--- '[ "col1" ::: 'Required ('NotNull 'PGint4)--- , "col2" ::: 'Required ('NotNull 'PGint4) ]--- manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar--- in renderManipulation manipulation--- :}--- "DELETE FROM tab WHERE (col1 = col2) RETURNING *;" deleteFrom- :: (SOP.SListI results, HasTable table schema columns)- => Alias table -- ^ table to delete from- -> Condition '[table ::: columns] 'Ungrouped params+ :: ( SOP.SListI results+ , Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to delete from+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to delete a row -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results-deleteFrom table wh returning = UnsafeManipulation $- "DELETE FROM" <+> renderAlias table+deleteFrom tab wh returning = UnsafeManipulation $+ "DELETE FROM" <+> renderAlias tab <+> "WHERE" <+> renderExpression wh <> renderReturningClause returning++-- | Delete rows returning `Nil`.+deleteFrom_+ :: ( Has tab schema table+ , columns ~ TableToColumns table )+ => Alias tab -- ^ table to delete from+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params+ -- ^ condition under which to delete a row+ -> Manipulation schema params '[]+deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)++{-----------------------------------------+WITH statements+-----------------------------------------}++-- | `with` provides a way to write auxiliary statements for use in a larger statement.+-- These statements, which are often referred to as Common Table Expressions or CTEs,+-- can be thought of as defining temporary tables that exist just for one statement.+--+-- >>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]+--+-- >>> :{+-- let+-- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: 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+-- :}+-- "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 schema params results+with commons manipulation = UnsafeManipulation $+ "WITH" <+> renderCommaSeparated renderCommon commons+ <+> renderManipulation manipulation+ where+ renderCommon+ :: Aliased (Manipulation schema params) common+ -> 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'
+ src/Squeal/PostgreSQL/Migration.hs view
@@ -0,0 +1,318 @@+{-|+Module: Squeal.PostgreSQL.Migration+Description: Squeal migrations+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++This module defines a `Migration` type to safely+change the schema of your database over time. Let's see an example!++>>> :set -XDataKinds -XOverloadedLabels+>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators+>>> :{+type UsersTable =+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ ]+:}++>>> :{+type EmailsTable =+ '[ "pk_emails" ::: 'PrimaryKey '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "email" ::: 'NoDef :=> 'Null 'PGtext+ ]+:}++>>> :{+let+ makeUsers :: Migration IO '[] '["users" ::: 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 )+ , down = void . define $ dropTable #users+ }+:}++>>> :{+let+ makeEmails :: Migration IO '["users" ::: UsersTable]+ '["users" ::: UsersTable, "emails" ::: 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)+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )+ , down = void . define $ dropTable #emails+ }+:}++Now that we have a couple migrations we can chain them together.++>>> let migrations = makeUsers :>> makeEmails :>> Done++>>> :{+let+ numMigrations+ :: Has "schema_migrations" schema MigrationsTable+ => PQ schema schema IO ()+ numMigrations = do+ result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))+ num <- ntuples result+ liftBase $ print num+:}++>>> :{+withConnection "host=localhost port=5432 dbname=exampledb" $+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")+ -- suppress notices+ & pqThen (migrateUp migrations)+ & pqThen numMigrations+ & pqThen (migrateDown migrations)+ & pqThen numMigrations+:}+Row 2+Row 0+-}++{-# LANGUAGE+ ScopedTypeVariables+ , OverloadedStrings+ , DataKinds+ , GADTs+ , LambdaCase+ , PolyKinds+ , OverloadedLabels+ , TypeApplications+ , FlexibleContexts+ , TypeOperators+#-}++module Squeal.PostgreSQL.Migration+ ( -- * Migration+ Migration (..)+ , migrateUp+ , migrateDown+ -- * Aligned lists+ , AlignedList (..)+ , single+ -- * Migration table+ , MigrationsTable+ , createMigrations+ , insertMigration+ , deleteMigration+ , selectMigration+ ) where++import Control.Category+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.Monoid+import Generics.SOP (K(..))+import Data.Function ((&))+import Data.Text (Text)+import Prelude hiding (id, (.))++import Squeal.PostgreSQL++-- | A `Migration` should contain an inverse pair of+-- `up` and `down` instructions and a unique `name`.+data Migration io schema0 schema1 = Migration+ { name :: Text -- ^ The `name` of a `Migration`.+ -- Each `name` in a `Migration` should be unique.+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.+ }++-- | An `AlignedList` is a type-aligned list or free category.+data AlignedList p x0 x1 where+ Done :: AlignedList p x x+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2+infixr 7 :>>+instance Category (AlignedList p) where+ id = Done+ (.) list = \case+ Done -> list+ step :>> steps -> step :>> (steps >>> list)++-- | A `single` step.+single :: p x0 x1 -> AlignedList p x0 x1+single step = step :>> Done++-- | Run `Migration`s by creating the `MigrationsTable`+-- if it does not exist and then in a transaction, for each each `Migration`+-- query to see if the `Migration` is executed. If not, then+-- execute the `Migration` and insert its row in the `MigrationsTable`.+migrateUp+ :: MonadBaseControl IO io+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run+ -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema0)+ ("schema_migrations" ::: MigrationsTable ': schema1)+ io ()+migrateUp migration =+ define createMigrations+ & pqBind okResult+ & pqThen (transactionallySchema_ (upMigrations migration))+ where++ upMigrations+ :: MonadBaseControl IO io+ => AlignedList (Migration io) schema0 schema1+ -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema0)+ ("schema_migrations" ::: MigrationsTable ': schema1)+ io ()+ upMigrations = \case+ Done -> return ()+ step :>> steps -> upMigration step & pqThen (upMigrations steps)++ upMigration+ :: MonadBase IO io+ => Migration io schema0 schema1 -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema0)+ ("schema_migrations" ::: MigrationsTable ': schema1)+ io ()+ upMigration step =+ queryExecuted step+ & pqBind (\ executed ->+ if executed == 1 -- up step has already been executed+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas+ else+ pqEmbed (up step) -- safely switch schemas+ & pqThen (manipulateParams insertMigration (Only (name step)))+ -- insert execution record+ & pqBind okResult)++ queryExecuted+ :: MonadBase IO io+ => Migration io schema0 schema1 -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema0)+ ("schema_migrations" ::: MigrationsTable ': schema0)+ io Row+ queryExecuted step = do+ result <- runQueryParams selectMigration (Only (name step))+ okResult result+ ntuples result++-- | Rewind `Migration`s by creating the `MigrationsTable`+-- if it does not exist and then in a transaction, for each each `Migration`+-- query to see if the `Migration` is executed. If it is, then+-- rewind the `Migration` and delete its row in the `MigrationsTable`.+migrateDown+ :: MonadBaseControl IO io+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind+ -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema1)+ ("schema_migrations" ::: MigrationsTable ': schema0)+ io ()+migrateDown migrations =+ define createMigrations+ & pqBind okResult+ & pqThen (transactionallySchema_ (downMigrations migrations))+ where++ downMigrations+ :: MonadBaseControl IO io+ => AlignedList (Migration io) schema0 schema1 -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema1)+ ("schema_migrations" ::: MigrationsTable ': schema0)+ io ()+ downMigrations = \case+ Done -> return ()+ step :>> steps -> downMigrations steps & pqThen (downMigration step)++ downMigration+ :: MonadBase IO io+ => Migration io schema0 schema1 -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema1)+ ("schema_migrations" ::: MigrationsTable ': schema0)+ io ()+ downMigration step =+ queryExecuted step+ & pqBind (\ executed ->+ if executed == 0 -- up step has not been executed+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas+ else+ pqEmbed (down step) -- safely switch schemas+ & pqThen (manipulateParams deleteMigration (Only (name step)))+ -- delete execution record+ & pqBind okResult)++ queryExecuted+ :: MonadBase IO io+ => Migration io schema0 schema1 -> PQ+ ("schema_migrations" ::: MigrationsTable ': schema1)+ ("schema_migrations" ::: MigrationsTable ': schema1)+ io Row+ queryExecuted step = do+ result <- runQueryParams selectMigration (Only (name step))+ okResult result+ ntuples result++okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()+okResult result = do+ status <- resultStatus result+ when (not (status `elem` [CommandOk, TuplesOk])) $ do+ errorMessageMaybe <- resultErrorMessage result+ case errorMessageMaybe of+ Nothing -> error "migrateDown: unknown error"+ Just msg -> error ("migrationDown: " <> show msg)++-- | The `TableType` for a Squeal migration.+type MigrationsTable =+ '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>+ '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext+ , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz+ ]++-- | Creates a `MigrationsTable` if it does not already exist.+createMigrations+ :: Has "schema_migrations" schema MigrationsTable+ => Definition schema schema+createMigrations =+ createTableIfNotExists #schema_migrations+ ( (text & notNull) `As` #name :*+ (timestampWithTimeZone & notNull & default_ currentTimestamp)+ `As` #executed_at :* Nil )+ ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )++-- | Inserts a `Migration` into the `MigrationsTable`+insertMigration+ :: Has "schema_migrations" schema MigrationsTable+ => Manipulation schema '[ 'NotNull 'PGtext] '[]+insertMigration = insertRow_ #schema_migrations+ ( Set (param @1) `As` #name :*+ Default `As` #executed_at :* Nil )++-- | Deletes a `Migration` from the `MigrationsTable`+deleteMigration+ :: Has "schema_migrations" schema 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+ => Query schema '[ 'NotNull 'PGtext ]+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]+selectMigration = select+ (#executed_at `As` #executed_at :* Nil)+ ( from (table (#schema_migrations `As` #m))+ & where_ (#name .== param @1))
src/Squeal/PostgreSQL/PQ.hs view
@@ -5,9 +5,17 @@ Maintainer: eitan@morphism.tech Stability: experimental -`Squeal.PostgreSQL.PQ` is where Squeal statements come to actually get run by-`LibPQ`. It contains a `PQ` indexed monad transformer to run `Definition`s and-a `MonadPQ` constraint for running a `Manipulation` or `Query`.+This module is where Squeal commands actually get executed by+`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing+a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,+and a `PQ` type with instances for them.++Using Squeal in your application will come down to defining+the @schema@ of your database and including @PQ schema schema@ in your+application's monad transformer stack, giving it an instance of `MonadPQ`.++This module also provides functions for retrieving rows from the `LibPQ.Result`+of executing Squeal commands. -} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}@@ -33,39 +41,38 @@ module Squeal.PostgreSQL.PQ ( -- * Connection- Connection (Connection, unConnection)+ LibPQ.Connection , connectdb , finish , withConnection+ , lowerConnection -- * PQ- , PQ (PQ, runPQ)+ , PQ (PQ, unPQ)+ , runPQ , execPQ- , pqAp- , pqBind- , pqThen- , define- , thenDefine- -- * MonadPQ+ , evalPQ+ , IndexedMonadTransPQ (..) , MonadPQ (..) , PQRun , pqliftWith -- * Result- , Result (Result, unResult)- , RowNumber (RowNumber, unRowNumber)- , ColumnNumber (UnsafeColumnNumber, getColumnNumber)- , HasColumnNumber (columnNumber)- , getValue+ , LibPQ.Result+ , LibPQ.Row+ , ntuples , getRow , getRows- , ntuples , nextRow , firstRow , liftResult+ , LibPQ.ExecStatus (..)+ , resultStatus+ , resultErrorMessage ) where import Control.Exception.Lifted import Control.Monad.Base import Control.Monad.Except+import Control.Monad.Morph import Control.Monad.Trans.Control import Data.ByteString (ByteString) import Data.Foldable@@ -74,8 +81,6 @@ import Data.Monoid import Data.Traversable import Generics.SOP-import GHC.Exts hiding (fromList)-import GHC.TypeLits import qualified Database.PostgreSQL.LibPQ as LibPQ @@ -99,11 +104,6 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict --- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`--- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`-newtype Connection (schema :: TablesType) =- Connection { unConnection :: LibPQ.Connection }- {- | Makes a new connection to the database server. This function opens a new database connection using the parameters taken@@ -119,8 +119,9 @@ To specify the schema you wish to connect with, use type application. >>> :set -XDataKinds+>>> :set -XPolyKinds >>> :set -XTypeOperators->>> type Schema = '["tab" ::: '["col" ::: 'Required ('Null 'PGint2)]]+>>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]] >>> :set -XTypeApplications >>> :set -XOverloadedStrings >>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"@@ -132,24 +133,30 @@ :: forall schema io . MonadBase IO io => ByteString -- ^ conninfo- -> io (Connection schema)-connectdb = fmap Connection . liftBase . LibPQ.connectdb+ -> io (K LibPQ.Connection schema)+connectdb = fmap K . liftBase . LibPQ.connectdb -- | Closes the connection to the server.-finish :: MonadBase IO io => Connection schema -> io ()-finish = liftBase . LibPQ.finish . unConnection+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()+finish = liftBase . LibPQ.finish . unK -- | Do `connectdb` and `finish` before and after a computation. withConnection :: forall schema0 schema1 io x . MonadBaseControl IO io => ByteString- -> (Connection schema0 -> io (x, Connection schema1))+ -> PQ schema0 schema1 io x -> io x withConnection connString action = do- (x, _conn) <- bracket (connectdb connString) finish action+ K x <- bracket (connectdb connString) finish (unPQ action) return x +-- | Safely `lowerConnection` to a smaller schema.+lowerConnection+ :: K LibPQ.Connection (table ': schema)+ -> K LibPQ.Connection schema+lowerConnection (K conn) = K conn+ -- | We keep track of the schema via an Atkey indexed state monad transformer, -- `PQ`. newtype PQ@@ -157,68 +164,114 @@ (schema1 :: TablesType) (m :: Type -> Type) (x :: Type) =- PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }- deriving Functor+ PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) } --- | Run a `PQ` and discard the result but keep the `Connection`. +instance Monad m => Functor (PQ schema0 schema1 m) where+ fmap f (PQ pq) = PQ $ \ conn -> do+ K x <- pq conn+ return $ K (f x)++-- | Run a `PQ` and keep the result and the `Connection`. +runPQ+ :: Functor m+ => PQ schema0 schema1 m x+ -> K LibPQ.Connection schema0+ -> m (x, K LibPQ.Connection schema1)+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`. execPQ :: Functor m => PQ schema0 schema1 m x- -> Connection schema0- -> m (Connection schema1)-execPQ (PQ pq) = fmap snd . pq+ -> K LibPQ.Connection schema0+ -> m (K LibPQ.Connection schema1)+execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn --- | indexed analog of `<*>`-pqAp- :: Monad m- => PQ schema0 schema1 m (x -> y)- -> PQ schema1 schema2 m x- -> PQ schema0 schema2 m y-pqAp (PQ f) (PQ x) = PQ $ \ conn -> do- (f', conn') <- f conn- (x', conn'') <- x conn'- return (f' x', conn'')+-- | Evaluate a `PQ` and discard the `Connection` but keep the result.+evalPQ+ :: Functor m+ => PQ schema0 schema1 m x+ -> K LibPQ.Connection schema0+ -> m x+evalPQ (PQ pq) conn = unK <$> pq conn --- | indexed analog of `=<<`-pqBind- :: Monad m- => (x -> PQ schema1 schema2 m y)- -> PQ schema0 schema1 m x- -> PQ schema0 schema2 m y-pqBind f (PQ x) = PQ $ \ conn -> do- (x', conn') <- x conn- runPQ (f x') conn'+-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`+-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).+-- An indexed monad transformer transforms a `Monad` into an indexed monad.+-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that+-- support running `Definition`s using `define` and embedding a computation+-- in a larger schema using `pqEmbed`.+class IndexedMonadTransPQ pq where --- | indexed analog of flipped `>>`-pqThen- :: Monad m- => PQ schema1 schema2 m y- -> PQ schema0 schema1 m x- -> PQ schema0 schema2 m y-pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)+ -- | indexed analog of `<*>`+ pqAp+ :: Monad m+ => pq schema0 schema1 m (x -> y)+ -> pq schema1 schema2 m x+ -> pq schema0 schema2 m y --- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law------ @define statement1 & thenDefine statement2 = define (statement1 >>> statement2)@-define- :: MonadBase IO io- => Definition schema0 schema1- -> PQ schema0 schema1 io (Result '[])-define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do- resultMaybe <- liftBase $ LibPQ.exec conn q- case resultMaybe of- Nothing -> error- "define: LibPQ.exec returned no results"- Just result -> return (Result result, Connection conn)+ -- | indexed analog of `join`+ pqJoin+ :: Monad m+ => pq schema0 schema1 m (pq schema1 schema2 m y)+ -> pq schema0 schema2 m y --- | Chain together `define` actions.-thenDefine- :: MonadBase IO io- => Definition schema1 schema2- -> PQ schema0 schema1 io x- -> PQ schema0 schema2 io (Result '[])-thenDefine = pqThen . define+ -- | indexed analog of `=<<`+ pqBind+ :: Monad m+ => (x -> pq schema1 schema2 m y)+ -> pq schema0 schema1 m x+ -> pq schema0 schema2 m y + -- | indexed analog of flipped `>>`+ pqThen+ :: Monad m+ => pq schema1 schema2 m y+ -> pq schema0 schema1 m x+ -> pq schema0 schema2 m y++ -- | Safely embed a computation in a larger schema.+ pqEmbed+ :: Monad m+ => pq schema0 schema1 m x+ -> pq (table ': schema0) (table : schema1) m x++ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law+ --+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@+ define+ :: MonadBase IO io+ => Definition schema0 schema1+ -> pq schema0 schema1 io (K LibPQ.Result '[])++instance IndexedMonadTransPQ PQ where++ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do+ K f' <- f conn+ 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++ define (UnsafeDefinition q) = PQ $ \ (K conn) -> do+ resultMaybe <- liftBase $ LibPQ.exec conn q+ case resultMaybe of+ Nothing -> error+ "define: LibPQ.exec returned no results"+ Just result -> return $ K (K result)+ {- | `MonadPQ` is an `mtl` style constraint, similar to `Control.Monad.State.Class.MonadState`, for using `LibPQ` to @@ -230,6 +283,8 @@ * `runQueryParams` is like `manipulateParams` for query statements. +* `runQuery` is like `runQueryParams` for a parameter-free statement.+ * `traversePrepared` has the same type signature as a composition of `traverse` and `manipulateParams` but provides an optimization by preparing the statement with `LibPQ.prepare` and then traversing a@@ -255,42 +310,42 @@ manipulateParams :: ToParams x params => Manipulation schema params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> x -> pq (Result ys)+ -- ^ `insertRows`, `update` or `deleteFrom`+ -> x -> pq (K LibPQ.Result ys) default manipulateParams :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1) => ToParams x params => Manipulation schema params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> x -> pq (Result ys)+ -- ^ `insertRows`, `update` or `deleteFrom`+ -> x -> pq (K LibPQ.Result ys) manipulateParams manipulation params = lift $ manipulateParams manipulation params - manipulate :: Manipulation schema '[] ys -> pq (Result ys)+ manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys) manipulate statement = manipulateParams statement () runQueryParams :: ToParams x params => Query schema params ys -- ^ `select` and friends- -> x -> pq (Result ys)+ -> x -> pq (K LibPQ.Result ys) runQueryParams = manipulateParams . queryStatement runQuery :: Query schema '[] ys -- ^ `select` and friends- -> pq (Result ys)+ -> pq (K LibPQ.Result ys) runQuery q = runQueryParams q () traversePrepared :: (ToParams x params, Traversable list) => Manipulation schema params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> list x -> pq (list (Result ys))+ -- ^ `insertRows`, `update`, or `deleteFrom`, and friends+ -> list x -> pq (list (K LibPQ.Result ys)) default traversePrepared :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1) => (ToParams x params, Traversable list)- => Manipulation schema params ys -> list x -> pq (list (Result ys))+ => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys)) traversePrepared manipulation params = lift $ traversePrepared manipulation params @@ -298,20 +353,20 @@ :: (ToParams x params, Traversable list) => list x -> Manipulation schema params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> pq (list (Result ys))+ -- ^ `insertRows`, `update` or `deleteFrom`+ -> pq (list (K LibPQ.Result ys)) forPrepared = flip traversePrepared traversePrepared_ :: (ToParams x params, Foldable list) => Manipulation schema params '[]- -- ^ `insertInto`, `update` or `deleteFrom`+ -- ^ `insertRows`, `update` or `deleteFrom` -> list x -> pq () default traversePrepared_ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1) => (ToParams x params, Foldable list) => Manipulation schema params '[]- -- ^ `insertInto`, `update` or `deleteFrom`+ -- ^ `insertRows`, `update` or `deleteFrom` -> list x -> pq () traversePrepared_ manipulation params = lift $ traversePrepared_ manipulation params@@ -320,7 +375,7 @@ :: (ToParams x params, Foldable list) => list x -> Manipulation schema params '[]- -- ^ `insertInto`, `update` or `deleteFrom`+ -- ^ `insertRows`, `update` or `deleteFrom` -> pq () forPrepared_ = flip traversePrepared_ @@ -330,11 +385,12 @@ => (LibPQ.Connection -> IO a) -> pq a liftPQ = lift . liftPQ -instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where+instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)+ => MonadPQ schema (PQ schema0 schema1 io) where manipulateParams (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =- PQ $ \ (Connection conn) -> do+ PQ $ \ (K conn) -> do let toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary) params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))@@ -342,11 +398,11 @@ case resultMaybe of Nothing -> error "manipulateParams: LibPQ.execParams returned no results"- Just result -> return (Result result, Connection conn)+ Just result -> return $ K (K result) traversePrepared (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =- PQ $ \ (Connection conn) -> liftBase $ do+ PQ $ \ (K conn) -> liftBase $ do let temp = "temporary_statement" prepResultMaybe <- LibPQ.prepare conn temp q Nothing case prepResultMaybe of@@ -364,7 +420,7 @@ case resultMaybe of Nothing -> error "traversePrepared: LibPQ.execParams returned no results"- Just result -> return $ Result result+ Just result -> return $ K result deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") case deallocResultMaybe of Nothing -> error@@ -373,11 +429,11 @@ status <- LibPQ.resultStatus deallocResult unless (status == LibPQ.CommandOk) . error $ "traversePrepared: DEALLOCATE status " <> show status- return (results, Connection conn)+ return (K results) traversePrepared_ (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =- PQ $ \ (Connection conn) -> liftBase $ do+ PQ $ \ (K conn) -> liftBase $ do let temp = "temporary_statement" prepResultMaybe <- LibPQ.prepare conn temp q Nothing case prepResultMaybe of@@ -404,11 +460,11 @@ status <- LibPQ.resultStatus deallocResult unless (status == LibPQ.CommandOk) . error $ "traversePrepared: DEALLOCATE status " <> show status- return ((), Connection conn)+ return (K ()) - liftPQ pq = PQ $ \ (Connection conn) -> do+ liftPQ pq = PQ $ \ (K conn) -> do y <- liftBase $ pq conn- return (y, Connection conn)+ return (K y) instance MonadPQ schema m => MonadPQ schema (IdentityT m) instance MonadPQ schema m => MonadPQ schema (ReaderT r m)@@ -423,91 +479,58 @@ instance MonadPQ schema m => MonadPQ schema (ContT r m) instance MonadPQ schema m => MonadPQ schema (ListT m) -instance Monad m => Applicative (PQ schema schema m) where- pure x = PQ $ \ conn -> pure (x, conn)+instance (Monad m, schema0 ~ schema1)+ => Applicative (PQ schema0 schema1 m) where+ pure x = PQ $ \ _conn -> pure (K x) (<*>) = pqAp -instance Monad m => Monad (PQ schema schema m) where+instance (Monad m, schema0 ~ schema1)+ => Monad (PQ schema0 schema1 m) where return = pure (>>=) = flip pqBind -instance MonadTrans (PQ schema schema) where- lift m = PQ $ \ conn -> do+instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where+ hoist f (PQ pq) = PQ (f . pq)++instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where+ lift m = PQ $ \ _conn -> do x <- m- return (x, conn)+ return (K x) -instance MonadBase b m => MonadBase b (PQ schema schema m) where+instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where+ embed f (PQ pq) = PQ $ \ conn -> do+ evalPQ (f (pq conn)) conn++instance (MonadBase b m, schema0 ~ schema1)+ => MonadBase b (PQ schema0 schema1 m) where liftBase = lift . liftBase -- | A snapshot of the state of a `PQ` computation. type PQRun schema =- forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)+ forall m x. Monad m => PQ schema schema m x -> m (K x schema) -- | Helper function in defining `MonadBaseControl` instance for `PQ`. pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a pqliftWith f = PQ $ \ conn ->- fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)+ fmap K (f $ \ pq -> unPQ pq conn) -instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where- type StM (PQ schema schema m) x = StM m (x, Connection schema)+instance (MonadBaseControl b m, schema0 ~ schema1)+ => MonadBaseControl b (PQ schema0 schema1 m) where+ type StM (PQ schema0 schema1 m) x = StM m (K x schema0) liftBaseWith f = pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run restoreM = PQ . const . restoreM --- | Encapsulates the result of a squeal command run by @LibPQ@.--- `Result`s are parameterized by a `ColumnsType` describing the column names--- and their types.-newtype Result (columns :: ColumnsType)- = Result { unResult :: LibPQ.Result }---- | Just newtypes around a `CInt`-newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }---- | In addition to being newtypes around a `CInt`, a `ColumnNumber` is--- parameterized by a `Nat`ural number and acts as an index into a row.-newtype ColumnNumber (n :: Nat) (cs :: [k]) (c :: k) =- UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }---- | >>> getColumnNumber (columnNumber @5 @'[_,_,_,_,_,_])--- Col 5-class KnownNat n => HasColumnNumber n columns column- | n columns -> column where- columnNumber :: ColumnNumber n columns column- columnNumber =- UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)-instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1-instance {-# OVERLAPPABLE #-}- (KnownNat n, HasColumnNumber (n-1) columns column)- => HasColumnNumber n (column' : columns) column---- | Get a single value corresponding to a given row and column number--- from a `Result`.-getValue- :: (FromColumnValue colty y, MonadBase IO io)- => RowNumber -- ^ row- -> ColumnNumber n columns colty -- ^ col- -> Result columns -- ^ result- -> io y-getValue- (RowNumber r)- (UnsafeColumnNumber c :: ColumnNumber n columns colty)- (Result result)- = fmap (fromColumnValue @colty . K) $ liftBase $ do- numRows <- LibPQ.ntuples result- when (numRows < r) $ error $- "getValue: expected at least " <> show r <> "rows but only saw "- <> show numRows- LibPQ.getvalue result r c---- | Get a row corresponding to a given row number from a `Result`.+-- | Get a row corresponding to a given row number from a `LibPQ.Result`,+-- throwing an exception if the row number is out of bounds. getRow :: (FromRow columns y, MonadBase IO io)- => RowNumber- -- ^ row- -> Result columns+ => LibPQ.Row+ -- ^ row number+ -> K LibPQ.Result columns -- ^ result -> io y-getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do+getRow r (K result :: K LibPQ.Result columns) = liftBase $ do numRows <- LibPQ.ntuples result when (numRows < r) $ error $ "getRow: expected at least " <> show r <> "rows but only saw "@@ -518,34 +541,30 @@ Nothing -> error "getRow: found unexpected length" Just row -> return $ fromRow @columns row --- | Returns the number of rows (tuples) in the query result.-ntuples :: MonadBase IO io => Result columns -> io RowNumber-ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result- -- | Intended to be used for unfolding in streaming libraries, `nextRow` -- takes a total number of rows (which can be found with `ntuples`)--- and a `Result` and given a row number if it's too large returns `Nothing`,+-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`, -- otherwise returning the row along with the next row number. nextRow :: (FromRow columns y, MonadBase IO io)- => RowNumber -- ^ total number of rows- -> Result columns -- ^ result- -> RowNumber -- ^ row number- -> io (Maybe (RowNumber,y))-nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)+ => LibPQ.Row -- ^ total number of rows+ -> K LibPQ.Result columns -- ^ result+ -> LibPQ.Row -- ^ row number+ -> io (Maybe (LibPQ.Row,y))+nextRow total (K result :: K LibPQ.Result columns) r = liftBase $ if r >= total then return Nothing else do let len = fromIntegral (lengthSList (Proxy @columns)) row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1] case fromList row' of Nothing -> error "nextRow: found unexpected length"- Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)+ Just row -> return $ Just (r+1, fromRow @columns row) --- | Get all rows from a `Result`.+-- | Get all rows from a `LibPQ.Result`. getRows :: (FromRow columns y, MonadBase IO io)- => Result columns -- ^ result+ => K LibPQ.Result columns -- ^ result -> io [y]-getRows (Result result :: Result columns) = liftBase $ do+getRows (K result :: K LibPQ.Result columns) = liftBase $ do let len = fromIntegral (lengthSList (Proxy @columns)) numRows <- LibPQ.ntuples result for [0 .. numRows - 1] $ \ r -> do@@ -554,12 +573,12 @@ Nothing -> error "getRows: found unexpected length" Just row -> return $ fromRow @columns row --- | Get the first row if possible from a `Result`.+-- | Get the first row if possible from a `LibPQ.Result`. firstRow :: (FromRow columns y, MonadBase IO io)- => Result columns -- ^ result+ => K LibPQ.Result columns -- ^ result -> io (Maybe y)-firstRow (Result result :: Result columns) = liftBase $ do+firstRow (K result :: K LibPQ.Result columns) = liftBase $ do numRows <- LibPQ.ntuples result if numRows <= 0 then return Nothing else do let len = fromIntegral (lengthSList (Proxy @columns))@@ -568,9 +587,23 @@ Nothing -> error "firstRow: found unexpected length" Just row -> return . Just $ fromRow @columns row --- | Lifts actions on results from `LibPQ`.+-- | Lifts actions on results from @LibPQ@. liftResult :: MonadBase IO io => (LibPQ.Result -> IO x)- -> Result results -> io x-liftResult f (Result result) = liftBase $ f result+ -> K LibPQ.Result results -> io x+liftResult f (K result) = liftBase $ f result++-- | Returns the number of rows (tuples) in the query result.+ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row+ntuples = liftResult LibPQ.ntuples++-- | Returns the result status of the command.+resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus+resultStatus = liftResult LibPQ.resultStatus++-- | Returns the error message most recently generated by an operation+-- on the connection.+resultErrorMessage+ :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)+resultErrorMessage = liftResult LibPQ.resultErrorMessage
+ src/Squeal/PostgreSQL/Pool.hs view
@@ -0,0 +1,133 @@+{-|+Module: Squeal.PostgreSQL.Definition+Description: Pooled connections+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++A `MonadPQ` for pooled connections.+-}++{-# LANGUAGE+ DataKinds+ , DeriveFunctor+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , RankNTypes+ , ScopedTypeVariables+ , TypeFamilies+ , TypeInType+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Pool+ ( -- * Pools+ PoolPQ (..)+ , createConnectionPool+ , Pool+ , destroyAllResources+ , PoolPQRun+ , poolpqliftWith+ ) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.ByteString+import Data.Pool+import Data.Time+import Generics.SOP (K(..))++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 =+ PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }+ deriving Functor++-- | Create a striped pool of connections.+-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.+createConnectionPool+ :: MonadBase IO io+ => ByteString+ -- ^ The passed string can be empty to use all default parameters, or it can+ -- contain one or more parameter settings separated by whitespace.+ -- Each parameter setting is in the form keyword = value. Spaces around the equal+ -- sign are optional. To write an empty value or a value containing spaces,+ -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and+ -- backslashes within the value must be escaped with a backslash, i.e., ' and \.+ -> Int+ -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.+ -> NominalDiffTime+ -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.+ -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.+ -> Int+ -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.+ -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.+ -> io (Pool (K Connection schema))+createConnectionPool conninfo stripes idle maxResrc = liftBase $+ createPool (connectdb conninfo) finish stripes idle maxResrc++-- | `Applicative` instance for `PoolPQ`.+instance Monad m => Applicative (PoolPQ schema m) where+ pure x = PoolPQ $ \ _ -> pure x+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do+ f' <- f pool+ x' <- x pool+ return $ f' x'++-- | `Monad` instance for `PoolPQ`.+instance Monad m => Monad (PoolPQ schema m) where+ return = pure+ PoolPQ x >>= f = PoolPQ $ \ pool -> do+ x' <- x pool+ runPoolPQ (f x') pool++-- | `MonadTrans` instance for `PoolPQ`.+instance MonadTrans (PoolPQ schema) where+ lift m = PoolPQ $ \ _pool -> m++-- | `MonadBase` instance for `PoolPQ`.+instance MonadBase b m => MonadBase b (PoolPQ schema m) where+ liftBase = lift . liftBase++-- | `MonadPQ` instance for `PoolPQ`.+instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where+ manipulateParams manipulation params = PoolPQ $ \ pool -> do+ withResource pool $ \ conn -> do+ (K result :: K (K Result ys) schema) <- flip unPQ conn $+ manipulateParams manipulation params+ return result+ traversePrepared manipulation params = PoolPQ $ \ pool ->+ withResource pool $ \ conn -> do+ (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $+ traversePrepared manipulation params+ return result+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do+ withResource pool $ \ conn -> do+ (_ :: K () schema) <- flip unPQ conn $+ traversePrepared_ manipulation params+ return ()+ liftPQ m = PoolPQ $ \ pool -> + withResource pool $ \ conn -> do+ (K result :: K result schema) <- flip unPQ conn $+ liftPQ m+ return result++-- | A snapshot of the state of a `PoolPQ` computation.+type PoolPQRun schema =+ forall m x. Monad m => PoolPQ schema m x -> m x++-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.+poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a+poolpqliftWith f = PoolPQ $ \ pool ->+ (f $ \ pq -> runPoolPQ pq pool)++-- | `MonadBaseControl` instance for `PoolPQ`.+instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where+ type StM (PoolPQ schema m) x = StM m x+ liftBaseWith f =+ poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run+ restoreM = PoolPQ . const . restoreM
− src/Squeal/PostgreSQL/Prettyprint.hs
@@ -1,67 +0,0 @@-{-|-Module: Squeal.PostgreSQL.PrettyPrint-Description: Pretty print helper functions-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--Pretty print helper functions.--}--{-# LANGUAGE- MagicHash- , OverloadedStrings- , PolyKinds- , RankNTypes- , ScopedTypeVariables- , TypeApplications-#-}--module Squeal.PostgreSQL.Prettyprint where--import Data.ByteString (ByteString)-import Data.Maybe-import Data.Monoid ((<>))-import Generics.SOP-import GHC.Exts-import GHC.TypeLits--import qualified Data.ByteString as ByteString---- | Parenthesize a `ByteString`.-parenthesized :: ByteString -> ByteString-parenthesized str = "(" <> str <> ")"---- | Concatenate two `ByteString`s with a space between.-(<+>) :: ByteString -> ByteString -> ByteString-str1 <+> str2 = str1 <> " " <> str2---- | Comma separate a list of `ByteString`s.-commaSeparated :: [ByteString] -> ByteString-commaSeparated = ByteString.intercalate ", "---- | Comma separate the renderings of a heterogeneous list.-renderCommaSeparated- :: SListI xs- => (forall x. expression x -> ByteString)- -> NP expression xs -> ByteString-renderCommaSeparated render- = commaSeparated- . hcollapse- . hmap (K . render)---- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping--- `Nothing`s.-renderCommaSeparatedMaybe- :: SListI xs- => (forall x. expression x -> Maybe ByteString)- -> NP expression xs -> ByteString-renderCommaSeparatedMaybe render- = commaSeparated- . catMaybes- . hcollapse- . hmap (K . render)---- | Render a promoted `Nat`.-renderNat :: KnownNat n => proxy n -> ByteString-renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
src/Squeal/PostgreSQL/Query.hs view
@@ -12,6 +12,7 @@ DataKinds , DeriveDataTypeable , DeriveGeneric+ , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving@@ -55,7 +56,13 @@ , offset -- * From , FromClause (..)- , renderFromClause+ , table+ , subquery+ , crossJoin+ , innerJoin+ , leftOuterJoin+ , rightOuterJoin+ , fullOuterJoin -- * Grouping , By (By, By2) , renderBy@@ -70,7 +77,7 @@ import Control.DeepSeq import Data.ByteString (ByteString)-import Data.Monoid+import Data.Monoid hiding (All) import Data.String import Data.Word import Generics.SOP hiding (from)@@ -79,7 +86,7 @@ import qualified GHC.Generics as GHC import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Schema {- |@@ -92,9 +99,11 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]- '["col" ::: 'Required ('Null 'PGint4)]- query = selectStar (from (Table (#tab `As` #t)))+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+ '[]+ '["col" ::: 'Null 'PGint4]+ query = selectStar (from (table (#tab `As` #t))) in renderQuery query :} "SELECT * FROM tab AS t"@@ -104,16 +113,16 @@ >>> :{ let query :: Query- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4) ]]+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]- '[ "sum" ::: 'Required ('NotNull 'PGint4)- , "col1" ::: 'Required ('NotNull 'PGint4) ]+ '[ "sum" ::: 'NotNull 'PGint4+ , "col1" ::: 'NotNull 'PGint4 ] query = select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- ( from (Table (#tab `As` #t))+ ( from (table (#tab `As` #t)) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) ) in renderQuery query@@ -124,11 +133,13 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]- '["col" ::: 'Required ('Null 'PGint4)]+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+ '[]+ '["col" ::: 'Null 'PGint4] query = selectStar- (from (Subquery (selectStar (from (Table (#tab `As` #t))) `As` #sub)))+ (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub))) in renderQuery query :} "SELECT * FROM (SELECT * FROM tab AS t) AS sub"@@ -137,10 +148,12 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]- '["col" ::: 'Required ('Null 'PGint4)]+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+ '[]+ '["col" ::: 'Null 'PGint4] query = selectStar- (from (Table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)+ (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2) in renderQuery query :} "SELECT * FROM tab AS t LIMIT 50 OFFSET 4"@@ -149,11 +162,12 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('NotNull 'PGfloat8)]]- '[ 'Required ('NotNull 'PGfloat8)]- '["col" ::: 'Required ('NotNull 'PGfloat8)]+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]]+ '[ 'NotNull 'PGfloat8]+ '["col" ::: 'NotNull 'PGfloat8] query = selectStar- (from (Table (#tab `As` #t)) & where_ (#col .> param @1))+ (from (table (#tab `As` #t)) & where_ (#col .> param @1)) in renderQuery query :} "SELECT * FROM tab AS t WHERE (col > ($1 :: float8))"@@ -163,15 +177,15 @@ >>> :{ let query :: Query- '[ "tab" :::- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4) ]]+ '[ "tab" ::: '[] :=>+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]- '[ "sum" ::: 'Required ('NotNull 'PGint4)- , "col1" ::: 'Required ('NotNull 'PGint4) ]+ '[ "sum" ::: 'NotNull 'PGint4+ , "col1" ::: 'NotNull 'PGint4 ] query = select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)- ( from (Table (#tab `As` #table1))+ ( from (table (#tab `As` #table1)) & group (By #col1 :* Nil) & having (#col1 + sum_ #col2 .> 1) ) in renderQuery query@@ -182,10 +196,12 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]- '["col" ::: 'Required ('Null 'PGint4)]+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+ '[]+ '["col" ::: 'Null 'PGint4] query = selectStar- (from (Table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])+ (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst]) in renderQuery query :} "SELECT * FROM tab AS t ORDER BY col ASC NULLS FIRST"@@ -197,33 +213,38 @@ let query :: Query '[ "orders" :::- '[ "id" ::: 'Required ('NotNull 'PGint4)- , "price" ::: 'Required ('NotNull 'PGfloat4)- , "customer_id" ::: 'Required ('NotNull 'PGint4)- , "shipper_id" ::: 'Required ('NotNull 'PGint4)+ '["pk_orders" ::: PrimaryKey '["id"]+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ] , "customers" :::- '[ "id" ::: 'Required ('NotNull 'PGint4)- , "name" ::: 'Required ('NotNull 'PGtext)+ '["pk_customers" ::: PrimaryKey '["id"]] :=>+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] , "shippers" :::- '[ "id" ::: 'Required ('NotNull 'PGint4)- , "name" ::: 'Required ('NotNull 'PGtext)+ '["pk_shippers" ::: PrimaryKey '["id"]] :=>+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ] '[]- '[ "order_price" ::: 'Required ('NotNull 'PGfloat4)- , "customer_name" ::: 'Required ('NotNull 'PGtext)- , "shipper_name" ::: 'Required ('NotNull 'PGtext)+ '[ "order_price" ::: 'NotNull 'PGfloat4+ , "customer_name" ::: 'NotNull 'PGtext+ , "shipper_name" ::: 'NotNull 'PGtext ] query = select ( #o ! #price `As` #order_price :* #c ! #name `As` #customer_name :* #s ! #name `As` #shipper_name :* Nil )- ( from (Table (#orders `As` #o)- & InnerJoin (Table (#customers `As` #c))+ ( from (table (#orders `As` #o)+ & innerJoin (table (#customers `As` #c)) (#o ! #customer_id .== #c ! #id)- & InnerJoin (Table (#shippers `As` #s))+ & innerJoin (table (#shippers `As` #s)) (#o ! #shipper_id .== #s ! #id)) ) in renderQuery query :}@@ -233,10 +254,12 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]- '["col" ::: 'Required ('Null 'PGint4)]+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+ '[]+ '["col" ::: 'Null 'PGint4] query = selectDotStar #t1- (from (Table (#tab `As` #t1) & CrossJoin (Table (#tab `As` #t2))))+ (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2)))) in renderQuery query :} "SELECT t1.* FROM tab AS t1 CROSS JOIN tab AS t2"@@ -245,21 +268,22 @@ >>> :{ let- query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]- '["col" ::: 'Required ('Null 'PGint4)]+ query :: Query+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]+ '[]+ '["col" ::: 'Null 'PGint4] query =- selectStar (from (Table (#tab `As` #t)))+ selectStar (from (table (#tab `As` #t))) `unionAll`- selectStar (from (Table (#tab `As` #t)))+ selectStar (from (table (#tab `As` #t))) in renderQuery query :} "(SELECT * FROM tab AS t) UNION ALL (SELECT * FROM tab AS t)" -}- newtype Query (schema :: TablesType)- (params :: [ColumnType])- (columns :: ColumnsType)+ (params :: [NullityType])+ (columns :: RelationType) = UnsafeQuery { renderQuery :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -340,73 +364,73 @@ -- the intermediate table are actually output. select :: SListI columns- => NP (Aliased (Expression tables grouping params)) (column ': columns)+ => NP (Aliased (Expression relations grouping params)) (column ': columns) -- ^ select list- -> TableExpression schema params tables grouping+ -> TableExpression schema params relations grouping -- ^ intermediate virtual table -> Query schema params (column ': columns)-select list tabs = UnsafeQuery $+select list rels = UnsafeQuery $ "SELECT"- <+> renderCommaSeparated (renderAliased renderExpression) list- <+> renderTableExpression tabs+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list+ <+> renderTableExpression rels -- | After the select list has been processed, the result table can -- be subject to the elimination of duplicate rows using `selectDistinct`. selectDistinct :: SListI columns- => NP (Aliased (Expression tables 'Ungrouped params)) (column ': columns)+ => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns) -- ^ select list- -> TableExpression schema params tables 'Ungrouped+ -> TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table -> Query schema params (column ': columns)-selectDistinct list tabs = UnsafeQuery $+selectDistinct list rels = UnsafeQuery $ "SELECT DISTINCT"- <+> renderCommaSeparated (renderAliased renderExpression) list- <+> renderTableExpression tabs+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list+ <+> renderTableExpression rels -- | The simplest kind of query is `selectStar` which emits all columns -- that the table expression produces. selectStar- :: HasUnique table tables columns- => TableExpression schema params tables 'Ungrouped+ :: HasUnique relation relations columns+ => TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table -> Query schema params columns-selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs+selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels -- | A `selectDistinctStar` emits all columns that the table expression -- produces and eliminates duplicate rows. selectDistinctStar- :: HasUnique table tables columns- => TableExpression schema params tables 'Ungrouped+ :: HasUnique relation relations columns+ => TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table -> Query schema params columns-selectDistinctStar tabs = UnsafeQuery $- "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs+selectDistinctStar rels = UnsafeQuery $+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels -- | When working with multiple tables, it can also be useful to ask -- for all the columns of a particular table, using `selectDotStar`. selectDotStar- :: HasTable table tables columns- => Alias table+ :: Has relation relations columns+ => Alias relation -- ^ particular virtual subtable- -> TableExpression schema params tables 'Ungrouped+ -> TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table -> Query schema params columns-selectDotStar table tables = UnsafeQuery $- "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables+selectDotStar rel relations = UnsafeQuery $+ "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations -- | A `selectDistinctDotStar` asks for all the columns of a particular table, -- and eliminates duplicate rows. selectDistinctDotStar- :: HasTable table tables columns- => Alias table- -- ^ particular virtual subtable- -> TableExpression schema params tables 'Ungrouped+ :: Has relation relations columns+ => Alias relation+ -- ^ particular virtual table+ -> TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table -> Query schema params columns-selectDistinctDotStar table tables = UnsafeQuery $- "SELECT DISTINCT" <+> renderAlias table <> ".*"- <+> renderTableExpression tables+selectDistinctDotStar rel relations = UnsafeQuery $+ "SELECT DISTINCT" <+> renderAlias rel <> ".*"+ <+> renderTableExpression relations {----------------------------------------- Table Expressions@@ -420,14 +444,14 @@ -- can be used to modify or combine base tables in various ways. data TableExpression (schema :: TablesType)- (params :: [ColumnType])- (tables :: TablesType)+ (params :: [NullityType])+ (relations :: RelationsType) (grouping :: Grouping) = TableExpression- { fromClause :: FromClause schema params tables+ { 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 tables 'Ungrouped params]+ , whereClause :: [Condition 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@@ -436,20 +460,20 @@ -- at least one column of the table generated in the `fromClause`; -- this is not required, but otherwise the WHERE clause will -- be fairly useless.- , groupByClause :: GroupByClause tables grouping+ , groupByClause :: GroupByClause relations grouping -- ^ The `groupByClause` is used to group together those rows in a table -- that have the same values in all the columns listed. The order in which -- the columns are listed does not matter. The effect is to combine each -- set of rows having common values into one group row that represents all -- rows in the group. This is done to eliminate redundancy in the output -- and/or compute aggregates that apply to these groups.- , havingClause :: HavingClause tables grouping params+ , havingClause :: HavingClause 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 tables grouping params]+ , orderByClause :: [SortExpression 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.@@ -467,11 +491,11 @@ -- | Render a `TableExpression` renderTableExpression- :: TableExpression schema params tables grouping+ :: TableExpression schema params relations grouping -> ByteString renderTableExpression- (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat- [ "FROM ", renderFromClause tables+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat+ [ "FROM ", renderFromClause frm' , renderWheres whs' , renderGroupByClause grps' , renderHavingClause hvs'@@ -501,68 +525,68 @@ -- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator -- to match the left-to-right sequencing of their placement in SQL. from- :: FromClause schema params tables -- ^ table reference- -> TableExpression schema params tables 'Ungrouped-from tables = TableExpression tables [] NoGroups NoHaving [] [] []+ :: FromClause schema params relations -- ^ table reference+ -> TableExpression schema params relations 'Ungrouped+from rels = TableExpression rels [] NoGroups NoHaving [] [] [] -- | A `where_` is an endomorphism of `TableExpression`s which adds a -- search condition to the `whereClause`. where_- :: Condition tables 'Ungrouped params- -> TableExpression schema params tables grouping- -> TableExpression schema params tables grouping-where_ wh tables = tables {whereClause = wh : whereClause tables}+ :: Condition relations 'Ungrouped params -- ^ filtering condition+ -> TableExpression schema params relations grouping+ -> TableExpression schema params relations grouping+where_ wh rels = rels {whereClause = wh : whereClause rels} -- | A `group` is a transformation of `TableExpression`s which switches -- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform -- a "grand total" aggregation query. group :: SListI bys- => NP (By tables) bys- -> TableExpression schema params tables 'Ungrouped - -> TableExpression schema params tables ('Grouped bys)-group bys tables = TableExpression- { fromClause = fromClause tables- , whereClause = whereClause tables+ => NP (By relations) bys -- ^ grouped columns+ -> TableExpression schema params relations 'Ungrouped + -> TableExpression schema params relations ('Grouped bys)+group bys rels = TableExpression+ { fromClause = fromClause rels+ , whereClause = whereClause rels , groupByClause = Group bys , havingClause = Having [] , orderByClause = []- , limitClause = limitClause tables- , offsetClause = offsetClause tables+ , limitClause = limitClause rels+ , offsetClause = offsetClause rels } -- | A `having` is an endomorphism of `TableExpression`s which adds a -- search condition to the `havingClause`. having- :: Condition tables ('Grouped bys) params- -> TableExpression schema params tables ('Grouped bys)- -> TableExpression schema params tables ('Grouped bys)-having hv tables = tables- { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }+ :: Condition relations ('Grouped bys) params -- ^ having condition+ -> TableExpression schema params relations ('Grouped bys)+ -> TableExpression schema params relations ('Grouped bys)+having hv rels = rels+ { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) } -- | An `orderBy` is an endomorphism of `TableExpression`s which appends an -- ordering to the right of the `orderByClause`. orderBy- :: [SortExpression tables grouping params]- -> TableExpression schema params tables grouping- -> TableExpression schema params tables grouping-orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}+ :: [SortExpression relations grouping params] -- ^ sort expressions+ -> TableExpression schema params relations grouping+ -> TableExpression schema params relations grouping+orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts} -- | A `limit` is an endomorphism of `TableExpression`s which adds to the -- `limitClause`. limit- :: Word64- -> TableExpression schema params tables grouping- -> TableExpression schema params tables grouping-limit lim tables = tables {limitClause = lim : limitClause tables}+ :: Word64 -- ^ limit parameter+ -> TableExpression schema params relations grouping+ -> TableExpression schema params relations grouping+limit lim rels = rels {limitClause = lim : limitClause rels} -- | An `offset` is an endomorphism of `TableExpression`s which adds to the -- `offsetClause`. offset- :: Word64- -> TableExpression schema params tables grouping- -> TableExpression schema params tables grouping-offset off tables = tables {offsetClause = off : offsetClause tables}+ :: Word64 -- ^ offset parameter+ -> TableExpression schema params relations grouping+ -> TableExpression schema params relations grouping+offset off rels = rels {offsetClause = off : offsetClause rels} {----------------------------------------- FROM clauses@@ -571,93 +595,107 @@ {- | A `FromClause` can be a table name, or a derived table such as a subquery, a @JOIN@ construct, or complex combinations of these.--* A real `Table` is a table from the schema.+-}+newtype FromClause schema params relations+ = UnsafeFromClause { renderFromClause :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData) -* `Subquery` derives a table from a `Query`.+-- | A real `table` is a table from the schema.+table+ :: Aliased (Table schema) table+ -> FromClause schema params '[table]+table = UnsafeFromClause . renderAliasedAs renderTable -* A joined table is a table derived from two other (real or derived) tables-according to the rules of the particular join type. `CrossJoin`, `InnerJoin`,-`LeftOuterJoin`, `RightOuterJoin` and `FullOuterJoin` are available and can-be nested using the `&` operator to match the left-to-right sequencing of-their placement in SQL.+-- | `subquery` derives a table from a `Query`.+subquery+ :: Aliased (Query schema params) table+ -> FromClause schema params '[table]+subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery) - * @t1 & CrossJoin t2@. For every possible combination of rows from- @t1@ and @t2@ (i.e., a Cartesian product), the joined table will contain- a row consisting of all columns in @t1@ followed by all columns in @t2@.+{- | @left & crossJoin right@. For every possible combination of rows from+ @left@ and @right@ (i.e., a Cartesian product), the joined table will contain+ a row consisting of all columns in @left@ followed by all columns in @right@. If the tables have @n@ and @m@ rows respectively, the joined table will have @n * m@ rows.+-}+crossJoin+ :: FromClause schema params right+ -- ^ right+ -> FromClause schema params left+ -- ^ left+ -> FromClause schema params (Join left right)+crossJoin right left = UnsafeFromClause $+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right - * @t1 & InnerJoin t2 on@. For each row @r1@ of @t1@, the joined- table has a row for each row in @t2@ that satisfies the @on@ condition- with @r1@+{- | @left & innerJoin right on@. The joined table is filtered by+the @on@ condition.+-}+innerJoin+ :: FromClause schema params right+ -- ^ right+ -> Condition (Join left right) 'Ungrouped params+ -- ^ @on@ condition+ -> FromClause schema params left+ -- ^ left+ -> FromClause schema params (Join left right)+innerJoin right on left = UnsafeFromClause $+ renderFromClause left <+> "INNER JOIN" <+> renderFromClause right+ <+> "ON" <+> renderExpression on - * @t1 & LeftOuterJoin t2 on@. First, an inner join is performed.- Then, for each row in @t1@ that does not satisfy the @on@ condition with- any row in @t2@, a joined row is added with null values in columns of @t2@.- Thus, the joined table always has at least one row for each row in @t1@.+{- | @left & leftOuterJoin right on@. First, an inner join is performed.+ Then, for each row in @left@ that does not satisfy the @on@ condition with+ any row in @right@, a joined row is added with null values in columns of @right@.+ Thus, the joined table always has at least one row for each row in @left@.+-}+leftOuterJoin+ :: FromClause schema params right+ -- ^ right+ -> Condition (Join left right) 'Ungrouped params+ -- ^ @on@ condition+ -> FromClause schema params left+ -- ^ left+ -> FromClause schema params (Join left (NullifyRelations right))+leftOuterJoin right on left = UnsafeFromClause $+ renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right+ <+> "ON" <+> renderExpression on - * @t1 & RightOuterJoin t2 on@. First, an inner join is performed.- Then, for each row in @t2@ that does not satisfy the @on@ condition with- any row in @t1@, a joined row is added with null values in columns of @t1@.+{- | @left & rightOuterJoin right on@. First, an inner join is performed.+ Then, for each row in @right@ that does not satisfy the @on@ condition with+ any row in @left@, a joined row is added with null values in columns of @left@. This is the converse of a left join: the result table will always- have a row for each row in @t2@.+ have a row for each row in @right@.+-}+rightOuterJoin+ :: FromClause schema params right+ -- ^ right+ -> Condition (Join left right) 'Ungrouped params+ -- ^ @on@ condition+ -> FromClause schema params left+ -- ^ left+ -> FromClause schema params (Join (NullifyRelations left) right)+rightOuterJoin right on left = UnsafeFromClause $+ renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right+ <+> "ON" <+> renderExpression on - * @t1 & FullOuterJoin t2 on@. First, an inner join is performed.- Then, for each row in @t1@ that does not satisfy the @on@ condition with- any row in @t2@, a joined row is added with null values in columns of @t2@.- Also, for each row of @t2@ that does not satisfy the join condition- with any row in @t1@, a joined row with null values in the columns of @t1@+{- | @left & fullOuterJoin right on@. First, an inner join is performed.+ Then, for each row in @left@ that does not satisfy the @on@ condition with+ any row in @right@, a joined row is added with null values in columns of @right@.+ Also, for each row of @right@ that does not satisfy the join condition+ with any row in @left@, a joined row with null values in the columns of @left@ is added. -}-data FromClause schema params tables where- Table- :: Aliased (Table schema) table- -> FromClause schema params '[table]- Subquery- :: Aliased (Query schema params) table- -> FromClause schema params '[table]- CrossJoin- :: FromClause schema params right- -> FromClause schema params left- -> FromClause schema params (Join left right)- InnerJoin- :: FromClause schema params right- -> Condition (Join left right) 'Ungrouped params- -> FromClause schema params left- -> FromClause schema params (Join left right)- LeftOuterJoin- :: FromClause schema params right- -> Condition (Join left right) 'Ungrouped params- -> FromClause schema params left- -> FromClause schema params (Join left (NullifyTables right))- RightOuterJoin- :: FromClause schema params right- -> Condition (Join left right) 'Ungrouped params- -> FromClause schema params left- -> FromClause schema params (Join (NullifyTables left) right)- FullOuterJoin- :: FromClause schema params right- -> Condition (Join left right) 'Ungrouped params- -> FromClause schema params left- -> FromClause schema params- (Join (NullifyTables left) (NullifyTables right))---- | Renders a `FromClause`.-renderFromClause :: FromClause schema params tables -> ByteString-renderFromClause = \case- Table table -> renderAliased renderTable table- Subquery selection -> renderAliased (parenthesized . renderQuery) selection- CrossJoin right left ->- renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right- InnerJoin right on left -> renderJoin "INNER JOIN" right on left- LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left- RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left- FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left- where- renderJoin op right on left =- renderFromClause left <+> op <+> renderFromClause right- <+> "ON" <+> renderExpression on+fullOuterJoin+ :: FromClause schema params right+ -- ^ right+ -> Condition (Join left right) 'Ungrouped params+ -- ^ @on@ condition+ -> FromClause schema params left+ -- ^ left+ -> FromClause schema params+ (Join (NullifyRelations left) (NullifyRelations right))+fullOuterJoin right on left = UnsafeFromClause $+ renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right+ <+> "ON" <+> renderExpression on {----------------------------------------- Grouping@@ -669,40 +707,41 @@ -- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table -- qualified column @tab.col@. data By- (tables :: TablesType)+ (relations :: RelationsType) (by :: (Symbol,Symbol)) where By- :: (HasUnique table tables columns, HasColumn column columns ty)+ :: (HasUnique relation relations columns, Has column columns ty) => Alias column- -> By tables '(table, column)+ -> By relations '(relation, column) By2- :: (HasTable table tables columns, HasColumn column columns ty)- => (Alias table, Alias column)- -> By tables '(table, column)-deriving instance Show (By tables by)-deriving instance Eq (By tables by)-deriving instance Ord (By tables by)+ :: (Has relation relations columns, Has column columns ty)+ => (Alias relation, Alias column)+ -> By relations '(relation, column)+deriving instance Show (By relations by)+deriving instance Eq (By relations by)+deriving instance Ord (By relations by) -- | Renders a `By`.-renderBy :: By tables tabcolty -> ByteString+renderBy :: By relations by -> ByteString renderBy = \case By column -> renderAlias column- By2 (table, column) -> renderAlias table <> "." <> renderAlias column+ By2 (rel, column) -> renderAlias rel <> "." <> renderAlias column -- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`. -- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`. -- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be -- done on @NoGroups@ while all output `Expression`s must be aggregated--- in @Group Nil@.-data GroupByClause tables grouping where- NoGroups :: GroupByClause tables 'Ungrouped+-- in @Group Nil@. In general, all output `Expression`s in the+-- complement of @bys@ must be aggregated in @Group bys@.+data GroupByClause relations grouping where+ NoGroups :: GroupByClause relations 'Ungrouped Group :: SListI bys- => NP (By tables) bys- -> GroupByClause tables ('Grouped bys)+ => NP (By relations) bys+ -> GroupByClause relations ('Grouped bys) -- | Renders a `GroupByClause`.-renderGroupByClause :: GroupByClause tables grouping -> ByteString+renderGroupByClause :: GroupByClause relations grouping -> ByteString renderGroupByClause = \case NoGroups -> "" Group Nil -> ""@@ -712,17 +751,17 @@ -- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped` -- `TableExpression` must use `Having` whose conditions are combined with -- `.&&`.-data HavingClause tables grouping params where- NoHaving :: HavingClause tables 'Ungrouped params+data HavingClause relations grouping params where+ NoHaving :: HavingClause relations 'Ungrouped params Having- :: [Condition tables ('Grouped bys) params]- -> HavingClause tables ('Grouped bys) params-deriving instance Show (HavingClause tables grouping params)-deriving instance Eq (HavingClause tables grouping params)-deriving instance Ord (HavingClause tables grouping params)+ :: [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) -- | Render a `HavingClause`.-renderHavingClause :: HavingClause tables grouping params -> ByteString+renderHavingClause :: HavingClause relations grouping params -> ByteString renderHavingClause = \case NoHaving -> "" Having [] -> ""@@ -741,29 +780,29 @@ -- `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 tables grouping params where+data SortExpression relations grouping params where Asc- :: Expression tables grouping params ('Required ('NotNull ty))- -> SortExpression tables grouping params+ :: Expression relations grouping params ('NotNull ty)+ -> SortExpression relations grouping params Desc- :: Expression tables grouping params ('Required ('NotNull ty))- -> SortExpression tables grouping params+ :: Expression relations grouping params ('NotNull ty)+ -> SortExpression relations grouping params AscNullsFirst- :: Expression tables grouping params ('Required ('Null ty))- -> SortExpression tables grouping params+ :: Expression relations grouping params ('Null ty)+ -> SortExpression relations grouping params AscNullsLast- :: Expression tables grouping params ('Required ('Null ty))- -> SortExpression tables grouping params+ :: Expression relations grouping params ('Null ty)+ -> SortExpression relations grouping params DescNullsFirst- :: Expression tables grouping params ('Required ('Null ty))- -> SortExpression tables grouping params+ :: Expression relations grouping params ('Null ty)+ -> SortExpression relations grouping params DescNullsLast- :: Expression tables grouping params ('Required ('Null ty))- -> SortExpression tables grouping params-deriving instance Show (SortExpression tables grouping params)+ :: Expression relations grouping params ('Null ty)+ -> SortExpression relations grouping params+deriving instance Show (SortExpression relations grouping params) -- | Render a `SortExpression`.-renderSortExpression :: SortExpression tables grouping params -> ByteString+renderSortExpression :: SortExpression relations grouping params -> ByteString renderSortExpression = \case Asc expression -> renderExpression expression <+> "ASC" Desc expression -> renderExpression expression <+> "DESC"
+ src/Squeal/PostgreSQL/Render.hs view
@@ -0,0 +1,75 @@+{-|+Module: Squeal.PostgreSQL.Render+Description: Rendering helper functions+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Rendering helper functions.+-}++{-# LANGUAGE+ MagicHash+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+#-}++module Squeal.PostgreSQL.Render+ ( -- * Render+ parenthesized+ , (<+>)+ , commaSeparated+ , renderCommaSeparated+ , renderCommaSeparatedMaybe+ , renderNat+ ) where++import Data.ByteString (ByteString)+import Data.Maybe+import Data.Monoid ((<>))+import Generics.SOP+import GHC.Exts+import GHC.TypeLits++import qualified Data.ByteString as ByteString++-- | Parenthesize a `ByteString`.+parenthesized :: ByteString -> ByteString+parenthesized str = "(" <> str <> ")"++-- | Concatenate two `ByteString`s with a space between.+(<+>) :: ByteString -> ByteString -> ByteString+str1 <+> str2 = str1 <> " " <> str2++-- | Comma separate a list of `ByteString`s.+commaSeparated :: [ByteString] -> ByteString+commaSeparated = ByteString.intercalate ", "++-- | Comma separate the renderings of a heterogeneous list.+renderCommaSeparated+ :: SListI xs+ => (forall x. expression x -> ByteString)+ -> NP expression xs -> ByteString+renderCommaSeparated render+ = commaSeparated+ . hcollapse+ . hmap (K . render)++-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping+-- `Nothing`s.+renderCommaSeparatedMaybe+ :: SListI xs+ => (forall x. expression x -> Maybe ByteString)+ -> NP expression xs -> ByteString+renderCommaSeparatedMaybe render+ = commaSeparated+ . catMaybes+ . hcollapse+ . hmap (K . render)++-- | Render a promoted `Nat`.+renderNat :: KnownNat n => proxy n -> ByteString+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
src/Squeal/PostgreSQL/Schema.hs view
@@ -5,17 +5,19 @@ Maintainer: eitan@morphism.tech Stability: experimental -Embedding of PostgreSQL type and alias system+A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. -} {-# LANGUAGE- ConstraintKinds+ AllowAmbiguousTypes+ , ConstraintKinds , DataKinds , DeriveAnyClass , DeriveDataTypeable , DeriveGeneric , FlexibleContexts , FlexibleInstances+ , FunctionalDependencies , GADTs , MagicHash , MultiParamTypeClasses@@ -28,43 +30,67 @@ , TypeFamilies , TypeInType , TypeOperators+ , UndecidableInstances #-} module Squeal.PostgreSQL.Schema- ( -- * Kinds+ ( -- * Types PGType (..)+ , HasOid (..) , NullityType (..)- , ColumnType (..)+ , ColumnType , ColumnsType+ , RelationType+ , NilRelation+ , RelationsType+ , TableType , TablesType+ , NilTables+ -- * Grouping , Grouping (..)+ , GroupedBy -- * Constraints- , PGNum- , PGIntegral- , PGFloating+ , (:=>)+ , ColumnConstraint (..)+ , TableConstraint (..)+ , TableConstraints+ , NilTableConstraints -- * Aliases , (:::) , Alias (Alias) , renderAlias , Aliased (As)- , renderAliased+ , renderAliasedAs+ , AliasesOf+ , Has+ , HasUnique , IsLabel (..)- , IsTableColumn (..)+ , IsQualified (..) -- * Type Families- , In- , HasUnique- , BaseType- , SameTypes- , AllNotNull- , NotAllNull- , NullifyType- , NullifyColumns- , NullifyTables , Join , Create , Drop , Alter , Rename+ , Elem+ , In+ , PGNum+ , PGIntegral+ , PGFloating+ , PGTypeOf+ , SameTypes+ , AllNotNull+ , NotAllNull+ , NullifyType+ , NullifyRelation+ , NullifyRelations+ , ColumnsToRelation+ , RelationToColumns+ , TableToColumns+ , TablesToRelations+ , RelationsToTables+ , ConstraintInvolves+ , DropIfConstraintsInvolve -- * Generics , SameField , SameFields@@ -74,6 +100,8 @@ import Data.ByteString import Data.Monoid import Data.String+import Data.Word+import Data.Type.Bool import Generics.SOP (AllZip) import GHC.Generics (Generic) import GHC.Exts@@ -83,6 +111,10 @@ import qualified Generics.SOP.Type.Metadata as Type -- | `PGType` is the promoted datakind of PostgreSQL types.+--+-- >>> import Squeal.PostgreSQL.Schema+-- >>> :kind 'PGbool+-- 'PGbool :: PGType data PGType = PGbool -- ^ logical Boolean (true/false) | PGint2 -- ^ signed two-byte integer@@ -105,61 +137,214 @@ | PGinet -- ^ IPv4 or IPv6 host address | PGjson -- ^ textual JSON data | PGjsonb -- ^ binary JSON data, decomposed+ | PGvararray PGType -- ^ variable length array+ | PGfixarray Nat PGType -- ^ fixed length array | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types +-- | The object identifier of a `PGType`.+--+-- >>> :set -XTypeApplications+-- >>> oid @'PGbool+-- 16+class HasOid (ty :: PGType) where oid :: Word32+instance HasOid 'PGbool where oid = 16+instance HasOid 'PGint2 where oid = 21+instance HasOid 'PGint4 where oid = 23+instance HasOid 'PGint8 where oid = 20+instance HasOid 'PGnumeric where oid = 1700+instance HasOid 'PGfloat4 where oid = 700+instance HasOid 'PGfloat8 where oid = 701+instance HasOid ('PGchar n) where oid = 18+instance HasOid ('PGvarchar n) where oid = 1043+instance HasOid 'PGtext where oid = 25+instance HasOid 'PGbytea where oid = 17+instance HasOid 'PGtimestamp where oid = 1114+instance HasOid 'PGtimestamptz where oid = 1184+instance HasOid 'PGdate where oid = 1082+instance HasOid 'PGtime where oid = 1083+instance HasOid 'PGtimetz where oid = 1266+instance HasOid 'PGinterval where oid = 1186+instance HasOid 'PGuuid where oid = 2950+instance HasOid 'PGinet where oid = 869+instance HasOid 'PGjson where oid = 114+instance HasOid 'PGjsonb where oid = 3802+ -- | `NullityType` encodes the potential presence or definite absence of a -- @NULL@ allowing operations which are sensitive to such to be well typed.+--+-- >>> :kind 'Null 'PGint4+-- 'Null 'PGint4 :: NullityType+-- >>> :kind 'NotNull ('PGvarchar 50)+-- 'NotNull ('PGvarchar 50) :: NullityType data NullityType = Null PGType -- ^ @NULL@ may be present | NotNull PGType -- ^ @NULL@ is absent --- | `ColumnType` encodes the allowance of @DEFAULT@ and the only way--- to generate an `Optional` `Squeal.PostgreSQL.Expression.Expression`--- is to use `Squeal.PostgreSQL.Expression.def`,--- `Squeal.PostgreSQL.Expression.unDef` or--- `Squeal.PostgreSQL.Expression.param`.-data ColumnType- = Optional NullityType- -- ^ @DEFAULT@ is allowed- | Required NullityType- -- ^ @DEFAULT@ is not allowed+-- | The constraint operator, `:=>` is a type level pair+-- between a "constraint" and some type, for use in pairing+-- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType`+-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.+type (:=>) constraint ty = '(constraint,ty)+infixr 7 :=> --- | `ColumnsType` is a kind synonym for a row of `ColumnType`s.+-- | 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`.+type (:::) (alias :: Symbol) ty = '(alias,ty)+infixr 6 :::++-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.+-- A column can be assigned a default value.+-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also+-- request explicitly that a column be set to its default value,+-- without having to know what that value is.+data ColumnConstraint+ = Def -- ^ @DEFAULT@ is available for inserts and updates+ | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates++-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the+-- base `PGType` for a column.+--+-- >>> :set -XTypeFamilies -XTypeInType+-- >>> import GHC.TypeLits+-- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4+-- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext+type ColumnType = (ColumnConstraint,NullityType)++-- | `ColumnsType` is a row of `ColumnType`s.+--+-- >>> :{+-- type family UsersColumns :: ColumnsType where+-- UsersColumns =+-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext+-- , "id" ::: 'Def :=> 'NotNull 'PGint4+-- ]+-- :} type ColumnsType = [(Symbol,ColumnType)] --- | `TablesType` is a kind synonym for a row of `ColumnsType`s.--- It is used as a kind for both a schema, a disjoint union of tables,--- and a joined table `Squeal.PostgreSQL.Query.FromClause`,--- a product of tables.-type TablesType = [(Symbol,ColumnsType)]+-- | `TableConstraint` encodes various forms of data constraints+-- of columns in a table.+-- `TableConstraint`s give you as much control over the data in your tables+-- as you wish. If a user attempts to store data in a column that would+-- violate a constraint, an error is raised. This applies+-- even if the value came from the default value definition.+data TableConstraint+ = Check [Symbol]+ | Unique [Symbol]+ | PrimaryKey [Symbol]+ | ForeignKey [Symbol] Symbol [Symbol] +-- | A `TableConstraints` is a row of `TableConstraint`s.+type TableConstraints = [(Symbol,TableConstraint)]+-- | A monokinded empty `TableConstraints`.+type family NilTableConstraints :: TableConstraints where+ NilTableConstraints = '[]++-- | `TableType` encodes a row of constraints on a table as well as the types+-- of its columns.+--+-- >>> :{+-- type family UsersTable :: TableType where+-- UsersTable =+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext+-- ]+-- :}+type TableType = (TableConstraints,ColumnsType)++-- | `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`+--+-- >>> :{+-- type family PersonRelation :: RelationType where+-- PersonRelation =+-- '[ "name" ::: 'NotNull 'PGtext+-- , "age" ::: 'NotNull 'PGint4+-- , "dateOfBirth" ::: 'Null 'PGdate+-- ]+-- :}+type RelationType = [(Symbol,NullityType)]+-- | A monokinded empty `RelationType`.+type family NilRelation :: RelationType where NilRelation = '[]++-- | `RelationsType` is a row of `RelationType`s, thought of as a product.+type RelationsType = [(Symbol,RelationType)]++-- | `ColumnsToRelation` removes column constraints.+type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where+ ColumnsToRelation '[] = '[]+ 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+ -- | `Grouping` is an auxiliary namespace, created by -- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used -- for typesafe aggregation data Grouping- = Ungrouped- | Grouped [(Symbol,Symbol)]---- | `PGNum` is a constraint on `PGType` whose--- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.-type PGNum ty =- In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]---- | `PGFloating` is a constraint on `PGType` whose--- `Squeal.PostgreSQL.Expression.Expression`s--- have `Fractional` and `Floating` constraints.-type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]---- | `PGIntegral` is a constraint on `PGType` whose--- `Squeal.PostgreSQL.Expression.Expression`s--- have `Squeal.PostgreSQL.Expression.div_` and--- `Squeal.PostgreSQL.Expression.mod_` functions.-type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]+ = Ungrouped -- ^ no aggregation permitted+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped --- | `:::` is like a promoted version of `As`, a type level pair between--- an alias and some type, usually a column alias and a `ColumnType` or--- a table alias and a `ColumnsType`.-type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)+{- | A `GroupedBy` constraint indicates that a table qualified column is+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.+-}+class (KnownSymbol relation, KnownSymbol column)+ => GroupedBy relation column bys where+instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)+ => GroupedBy relation column ('(table,column) ': bys)+instance {-# OVERLAPPABLE #-}+ ( KnownSymbol relation+ , KnownSymbol column+ , GroupedBy relation column bys+ ) => GroupedBy relation column (tabcol ': bys) -- | `Alias`es are proxies for a type level string or `Symbol` -- and have an `IsLabel` instance so that with @-XOverloadedLabels@@@ -172,8 +357,8 @@ instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where fromLabel = Alias --- | >>> renderAlias #alias--- "alias"+-- | >>> renderAlias #jimbob+-- "jimbob" renderAlias :: KnownSymbol alias => Alias alias -> ByteString renderAlias = fromString . symbolVal @@ -196,76 +381,108 @@ => Ord (Aliased expression (alias ::: ty)) -- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")--- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)+-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int) -- "Just AS an_int"-renderAliased+renderAliasedAs :: (forall ty. expression ty -> ByteString) -> Aliased expression aliased -> ByteString-renderAliased render (expression `As` alias) =+renderAliasedAs render (expression `As` alias) = render expression <> " AS " <> renderAlias alias +-- | `AliasesOf` retains the AliasesOf in a row.+type family AliasesOf aliaseds where+ AliasesOf '[] = '[]+ AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys++-- | @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@.+class KnownSymbol alias =>+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)+ | alias fields -> field where+instance {-# OVERLAPPING #-} KnownSymbol alias+ => Has alias (alias ::: field ': fields) field+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)+ => Has alias (field' ': fields) field+ -- | Analagous to `IsLabel`, the constraint--- `IsTableColumn` defines `!` for a column alias qualified+-- `IsQualified` defines `!` for a column alias qualified -- by a table alias.-class IsTableColumn table column expression where+class IsQualified table column expression where (!) :: Alias table -> Alias column -> expression infixl 9 !-instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)+instance IsQualified table column (Alias table, Alias column) where (!) = (,) +-- | @Elem@ is a promoted `Data.List.elem`.+type family Elem x xs where+ Elem x '[] = 'False+ Elem x (x ': xs) = 'True+ Elem x (_ ': xs) = Elem x xs+ -- | @In x xs@ is a constraint that proves that @x@ is in @xs@.-type family In x xs :: Constraint where- In x (x ': xs) = ()- In x (y ': xs) = In x xs+type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True --- | @HasUnique alias xs x@ is a constraint that proves that @xs@ is a singleton--- of @alias ::: x@.-type HasUnique alias xs x = xs ~ '[alias ::: x]+-- | `PGNum` is a constraint on `PGType` whose+-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.+type PGNum ty =+ In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8] --- | `BaseType` forgets about @NULL@ and @DEFAULT@-type family BaseType (ty :: ColumnType) :: PGType where- BaseType (optionality (nullity pg)) = pg+-- | `PGFloating` is a constraint on `PGType` whose+-- `Squeal.PostgreSQL.Expression.Expression`s+-- have `Fractional` and `Floating` constraints.+type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric] +-- | `PGIntegral` is a constraint on `PGType` whose+-- `Squeal.PostgreSQL.Expression.Expression`s+-- have `Squeal.PostgreSQL.Expression.div_` and+-- `Squeal.PostgreSQL.Expression.mod_` functions.+type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]++-- | `PGTypeOf` forgets about @NULL@ and any column constraints.+type family PGTypeOf (ty :: NullityType) :: PGType where+ PGTypeOf (nullity pg) = pg+ -- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same -- length and the same `ColumnType`s.-type family SameTypes- (columns0 :: ColumnsType) (columns1 :: ColumnsType)- :: Constraint where+type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)+ :: Constraint where SameTypes '[] '[] = ()- SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)+ SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1) = (ty0 ~ ty1, SameTypes columns0 columns1) -- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. type family AllNotNull (columns :: ColumnsType) :: Constraint where AllNotNull '[] = ()- AllNotNull ((column ::: (optionality ('NotNull ty))) ': columns)- = AllNotNull columns+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns -- | `NotAllNull` is a constraint that proves a `ColumnsType` has some -- @NOT NULL@.-type family NotAllNull columns :: Constraint where- NotAllNull ((column ::: (optionality ('NotNull ty))) ': columns) = ()- NotAllNull ((column ::: (optionality ('Null ty))) ': columns)- = NotAllNull columns+type family NotAllNull (columns :: ColumnsType) :: Constraint where+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns -- | `NullifyType` is an idempotent that nullifies a `ColumnType`.-type family NullifyType (ty :: ColumnType) :: ColumnType where- NullifyType (optionality ('Null ty)) = optionality ('Null ty)- NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)+type family NullifyType (ty :: NullityType) :: NullityType where+ NullifyType ('Null ty) = 'Null ty+ NullifyType ('NotNull ty) = 'Null ty --- | `NullifyColumns` is an idempotent that nullifies a `ColumnsType`.-type family NullifyColumns (columns :: ColumnsType) :: ColumnsType where- NullifyColumns '[] = '[]- NullifyColumns ((column ::: ty) ': columns) =- (column ::: NullifyType ty) ': NullifyColumns columns+-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.+type family NullifyRelation (columns :: RelationType) :: RelationType where+ NullifyRelation '[] = '[]+ NullifyRelation (column ::: ty ': columns) =+ column ::: NullifyType ty ': NullifyRelation columns --- | `NullifyTables` is an idempotent that nullifies a `TablesType`+-- | `NullifyRelations` is an idempotent that nullifies a `RelationsType` -- used to nullify the left or right hand side of an outer join -- in a `Squeal.PostgreSQL.Query.FromClause`.-type family NullifyTables (tables :: TablesType) :: TablesType where- NullifyTables '[] = '[]- NullifyTables ((table ::: columns) ': tables) =- (table ::: NullifyColumns columns) ': NullifyTables tables+type family NullifyRelations (tables :: RelationsType) :: RelationsType where+ NullifyRelations '[] = '[]+ NullifyRelations (table ::: columns ': tables) =+ table ::: NullifyRelation columns ': NullifyRelations tables -- | `Join` is simply promoted `++` and is used in @JOIN@s in -- `Squeal.PostgreSQL.Query.FromClause`s.@@ -275,8 +492,7 @@ -- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in -- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@--- `Squeal.PostgreSQL.Definition.addColumnDefault` and--- `Squeal.PostgreSQL.Definition.addColumnNull` statements.+-- `Squeal.PostgreSQL.Definition.addColumn`. type family Create alias x xs where Create alias x '[] = '[alias ::: x] Create alias y (x ': xs) = x ': Create alias y xs@@ -295,6 +511,19 @@ Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1 +-- type family AddConstraint constraint ty where+-- AddConstraint constraint (constraints :=> ty)+-- = AsSet (constraint ': constraints) :=> ty++-- type family DeleteFromList (e :: elem) (list :: [elem]) where+-- DeleteFromList elem '[] = '[]+-- DeleteFromList elem (x ': xs) =+-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)++-- type family DropConstraint constraint ty where+-- DropConstraint constraint (constraints :=> ty)+-- = (AsSet (DeleteFromList constraint constraints)) :=> ty+ -- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@ -- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and -- `Squeal.PostgreSQL.Definition.renameColumn`.@@ -305,14 +534,14 @@ -- | 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,ColumnType)) where+ (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 aliases of a `ColumnsType`.+-- field names as the column AliasesOf of a `ColumnsType`. type family SameFields- (datatypeInfo :: Type.DatatypeInfo) (columns :: ColumnsType)+ (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType) :: Constraint where SameFields ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])@@ -322,3 +551,19 @@ ('Type.Newtype _module _datatype ('Type.Record _constructor fields)) columns = AllZip SameField fields columns++-- | Check if a `TableConstraint` involves a column+type family ConstraintInvolves column constraint where+ ConstraintInvolves column ('Check columns) = column `Elem` columns+ ConstraintInvolves column ('Unique columns) = column `Elem` columns+ ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns+ ConstraintInvolves column ('ForeignKey columns tab refcolumns)+ = column `Elem` columns++-- | Drop all `TableConstraint`s that involve a column+type family DropIfConstraintsInvolve column constraints where+ DropIfConstraintsInvolve column '[] = '[]+ DropIfConstraintsInvolve column (alias ::: constraint ': constraints)+ = If (ConstraintInvolves column constraint)+ (DropIfConstraintsInvolve column constraints)+ (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
+ src/Squeal/PostgreSQL/Transaction.hs view
@@ -0,0 +1,232 @@+{-|+Module: Squeal.PostgreSQL.Transaction+Description: Squeal transaction control language+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal transaction control language.+-}++{-# LANGUAGE+ DataKinds+ , EmptyCase+ , FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , OverloadedStrings+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , TypeFamilies+ , TypeInType+#-}++module Squeal.PostgreSQL.Transaction+ ( -- * Transaction+ transactionally+ , transactionally_+ , begin+ , commit+ , rollback+ , transactionallySchema+ , transactionallySchema_+ -- * Transaction Mode+ , TransactionMode (..)+ , defaultMode+ , longRunningMode+ , IsolationLevel (..)+ , renderIsolationLevel+ , AccessMode (..)+ , renderAccessMode+ , DeferrableMode (..)+ , renderDeferrableMode+ ) where++import Control.Exception.Lifted+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.ByteString+import Data.Monoid+import Generics.SOP++import qualified Database.PostgreSQL.LibPQ as LibPQ++import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.PQ+import Squeal.PostgreSQL.Schema++-- | Run a schema invariant computation `transactionally`.+transactionally+ :: (MonadBaseControl IO tx, MonadPQ schema tx)+ => TransactionMode+ -> tx x -- ^ run inside a transaction+ -> tx x+transactionally mode tx = mask $ \restore -> do+ _ <- begin mode+ result <- restore tx `onException` rollback+ _ <- commit+ return result++-- | Run a schema invariant computation `transactionally_` in `defaultMode`.+transactionally_+ :: (MonadBaseControl IO tx, MonadPQ schema tx)+ => tx x -- ^ run inside a transaction+ -> tx x+transactionally_ = transactionally defaultMode++-- | @BEGIN@ a transaction.+begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)+begin mode = manipulate . UnsafeManipulation $+ "BEGIN" <+> renderTransactionMode mode <> ";"++-- | @COMMIT@ a schema invariant transaction.+commit :: MonadPQ schema tx => tx (K Result NilRelation)+commit = manipulate $ UnsafeManipulation "COMMIT;"++-- | @ROLLBACK@ a schema invariant transaction.+rollback :: MonadPQ schema tx => tx (K Result NilRelation)+rollback = manipulate $ UnsafeManipulation "ROLLBACK;"++-- | Run a schema changing computation `transactionallySchema`.+transactionallySchema+ :: MonadBaseControl IO io+ => TransactionMode+ -> PQ schema0 schema1 io x+ -> PQ schema0 schema1 io x+transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do+ _ <- liftBase . LibPQ.exec (unK conn) $+ "BEGIN" <+> renderTransactionMode mode <> ";"+ x <- restore (unPQ u conn)+ `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))+ _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"+ return x++-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.+transactionallySchema_+ :: MonadBaseControl IO io+ => PQ schema0 schema1 io x+ -> PQ schema0 schema1 io x+transactionallySchema_ = transactionallySchema defaultMode++-- | The available transaction characteristics are the transaction `IsolationLevel`,+-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.+data TransactionMode = TransactionMode+ { isolationLevel :: IsolationLevel+ , accessMode :: AccessMode+ , deferrableMode :: DeferrableMode+ } deriving (Show, Eq)++-- | `TransactionMode` with a `Serializable` `IsolationLevel`,+-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.+defaultMode :: TransactionMode+defaultMode = TransactionMode Serializable ReadWrite NotDeferrable++-- | `TransactionMode` with a `Serializable` `IsolationLevel`,+-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.+-- This mode is well suited for long-running reports or backups.+longRunningMode :: TransactionMode+longRunningMode = TransactionMode Serializable ReadOnly Deferrable++-- | Render a `TransactionMode`.+renderTransactionMode :: TransactionMode -> ByteString+renderTransactionMode mode =+ "ISOLATION LEVEL"+ <+> renderIsolationLevel (isolationLevel mode)+ <+> renderAccessMode (accessMode mode)+ <+> renderDeferrableMode (deferrableMode mode)++-- | The SQL standard defines four levels of transaction isolation.+-- The most strict is `Serializable`, which is defined by the standard in a paragraph+-- which says that any concurrent execution of a set of `Serializable` transactions is+-- guaranteed to produce the same effect as running them one at a time in some order.+-- The other three levels are defined in terms of phenomena, resulting from interaction+-- between concurrent transactions, which must not occur at each level.+-- The phenomena which are prohibited at various levels are:+--+-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.+--+-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data+-- has been modified by another transaction (that committed since the initial read).+--+-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy+-- a search condition and finds that the set of rows satisfying the condition+-- has changed due to another recently-committed transaction.+--+-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent+-- with all possible orderings of running those transactions one at a time.+--+-- In PostgreSQL, you can request any of the four standard transaction+-- isolation levels, but internally only three distinct isolation levels are implemented,+-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.+-- This is because it is the only sensible way to map the standard isolation levels to+-- PostgreSQL's multiversion concurrency control architecture.+data IsolationLevel+ = Serializable+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is not possible.+ -- Phantom read is not possible. + -- Serialization anomaly is not possible.+ | RepeatableRead+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is not possible.+ -- Phantom read is not possible. + -- Serialization anomaly is possible.+ | ReadCommitted+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is possible.+ -- Phantom read is possible. + -- Serialization anomaly is possible.+ | ReadUncommitted+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is possible.+ -- Phantom read is possible. + -- Serialization anomaly is possible.+ deriving (Show, Eq)++-- | Render an `IsolationLevel`.+renderIsolationLevel :: IsolationLevel -> ByteString+renderIsolationLevel = \case+ Serializable -> "SERIALIZABLE"+ ReadCommitted -> "READ COMMITTED"+ ReadUncommitted -> "READ UNCOMMITTED"+ RepeatableRead -> "REPEATABLE READ"++-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.+-- `ReadWrite` is the default. When a transaction is `ReadOnly`,+-- the following SQL commands are disallowed:+-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@+-- if the table they would write to is not a temporary table;+-- all @CREATE@, @ALTER@, and @DROP@ commands;+-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;+-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.+-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.+data AccessMode+ = ReadWrite+ | ReadOnly+ deriving (Show, Eq)++-- | Render an `AccessMode`.+renderAccessMode :: AccessMode -> ByteString+renderAccessMode = \case+ ReadWrite -> "READ WRITE"+ ReadOnly -> "READ ONLY"++-- | The `Deferrable` transaction property has no effect+-- unless the transaction is also `Serializable` and `ReadOnly`.+-- When all three of these properties are selected for a transaction,+-- the transaction may block when first acquiring its snapshot,+-- after which it is able to run without the normal overhead of a+-- `Serializable` transaction and without any risk of contributing+-- to or being canceled by a serialization failure.+-- This `longRunningMode` is well suited for long-running reports or backups.+data DeferrableMode+ = Deferrable+ | NotDeferrable+ deriving (Show, Eq)++-- | Render a `DeferrableMode`.+renderDeferrableMode :: DeferrableMode -> ByteString+renderDeferrableMode = \case+ Deferrable -> "DEFERRABLE"+ NotDeferrable -> "NOT DEFERRABLE"
test/DocTest.hs view
@@ -5,10 +5,14 @@ main :: IO () main = doctest [ "-isrc"+ , "src/Squeal/PostgreSQL.hs" , "src/Squeal/PostgreSQL/Binary.hs" , "src/Squeal/PostgreSQL/Definition.hs" , "src/Squeal/PostgreSQL/Manipulation.hs" , "src/Squeal/PostgreSQL/Query.hs" , "src/Squeal/PostgreSQL/Expression.hs" , "src/Squeal/PostgreSQL/PQ.hs"+ , "src/Squeal/PostgreSQL/Migration.hs"+ , "src/Squeal/PostgreSQL/Transaction.hs"+ , "src/Squeal/PostgreSQL/Pool.hs" ]
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/Squeal/PostgreSQL/DefinitionSpec.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE- DataKinds- , MagicHash- , OverloadedLabels- , OverloadedStrings- , TypeApplications- , TypeOperators-#-}--module Squeal.PostgreSQL.DefinitionSpec where--import Control.Category ((>>>))-import Data.Function-import Generics.SOP hiding (from)-import Test.Hspec--import Squeal.PostgreSQL--spec :: Spec-spec = do- let- definition `definitionRenders` str =- renderDefinition definition `shouldBe` str- it "should render CREATE TABLE statements" $ do- createTable #table1- ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)- [primaryKey (Column #col1 :* Column #col2 :* Nil)]- `definitionRenders`- "CREATE TABLE table1\- \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\- \ PRIMARY KEY (col1, col2));"- createTable #table2- ( serial `As` #col1 :*- text `As` #col2 :*- (int8 & notNull & default_ 8) `As` #col3 :* Nil )- [check (#col3 .> 0)]- `definitionRenders`- "CREATE TABLE table2\- \ (col1 serial,\- \ col2 text,\- \ col3 int8 NOT NULL DEFAULT 8,\- \ CHECK ((col3 > 0)));"- let- statement :: Definition '[]- '[ "users" :::- '[ "id" ::: 'Optional ('NotNull 'PGint4)- , "username" ::: 'Required ('NotNull 'PGtext)- ]- , "emails" :::- '[ "id" ::: 'Optional ('NotNull 'PGint4)- , "userid" ::: 'Required ('NotNull 'PGint4)- , "email" ::: 'Required ('NotNull 'PGtext)- ]- ]- statement =- createTable #users- (serial `As` #id :* (text & notNull) `As` #username :* Nil)- [primaryKey (Column #id :* Nil)]- >>>- createTable #emails- ( serial `As` #id :*- (integer & notNull) `As` #userid :*- (text & notNull) `As` #email :* Nil )- [ primaryKey (Column #id :* Nil)- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)- OnDeleteCascade OnUpdateRestrict- , unique (Column #email :* Nil)- , check (#email ./= "")- ]- statement `definitionRenders`- "CREATE TABLE users\- \ (id serial, username text NOT NULL,\- \ PRIMARY KEY (id));\- \ \- \CREATE TABLE emails\- \ (id serial,\- \ userid integer NOT NULL,\- \ email text NOT NULL,\- \ PRIMARY KEY (id),\- \ FOREIGN KEY (userid) REFERENCES users (id)\- \ ON DELETE CASCADE ON UPDATE RESTRICT,\- \ UNIQUE (email),\- \ CHECK ((email <> E'')));"- it "should render DROP TABLE statements" $ do- let- statement :: Definition Tables '[]- statement = dropTable #table1- statement `definitionRenders` "DROP TABLE table1;"--type Columns =- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4)- ]-type Tables = '[ "table1" ::: Columns ]-type SumAndCol1 =- '[ "sum" ::: 'Required ('NotNull 'PGint4)- , "col1" ::: 'Required ('NotNull 'PGint4)- ]-type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]-type StudentsTable = '["students" ::: StudentsColumns]-type OrderColumns =- '[ "orderID" ::: 'Required ('NotNull 'PGint4)- , "orderVal" ::: 'Required ('NotNull 'PGtext)- , "customerID" ::: 'Required ('NotNull 'PGint4)- , "shipperID" ::: 'Required ('NotNull 'PGint4)- ]-type CustomerColumns =- '[ "customerID" ::: 'Required ('NotNull 'PGint4)- , "customerVal" ::: 'Required ('NotNull 'PGfloat4)- ]-type ShipperColumns =- '[ "shipperID" ::: 'Required ('NotNull 'PGint4)- , "shipperVal" ::: 'Required ('NotNull 'PGbool)- ]-type JoinTables =- '[ "orders" ::: OrderColumns- , "customers" ::: CustomerColumns- , "shippers" ::: ShipperColumns- ]-type ValueColumns =- '[ "orderVal" ::: 'Required ('NotNull 'PGtext)- , "customerVal" ::: 'Required ('NotNull 'PGfloat4)- , "shipperVal" ::: 'Required ('NotNull 'PGbool)- ]
− test/Squeal/PostgreSQL/ManipulationSpec.hs
@@ -1,128 +0,0 @@-{-# LANGUAGE- DataKinds- , MagicHash- , OverloadedLabels- , OverloadedStrings- , TypeApplications- , TypeOperators-#-}--module Squeal.PostgreSQL.ManipulationSpec where--import Generics.SOP hiding (from)-import Test.Hspec--import Squeal.PostgreSQL--spec :: Spec-spec = do- let- manipulation `manipulationRenders` str =- renderManipulation manipulation `shouldBe` str- it "correctly renders returning INSERTs" $ do- let- statement :: Manipulation Tables '[] SumAndCol1- statement =- insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])- OnConflictDoRaise- (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- statement `manipulationRenders`- "INSERT INTO table1 (col1, col2) VALUES (2, 4)\- \ RETURNING (col1 + col2) AS sum, col1 AS col1;"- it "correctly renders simple UPDATEs" $ do- let- statement :: Manipulation Tables '[] '[]- statement =- update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)- (#col1 ./= #col2) (Returning Nil)- statement `manipulationRenders`- "UPDATE table1 SET col1 = 2\- \ WHERE (col1 <> col2);"- it "correctly renders returning UPDATEs" $ do- let- statement :: Manipulation Tables '[] SumAndCol1- statement =- update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)- (#col1 ./= #col2)- (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- statement `manipulationRenders`- "UPDATE table1 SET col1 = 2\- \ WHERE (col1 <> col2)\- \ RETURNING (col1 + col2) AS sum, col1 AS col1;"- it "correctly renders upsert INSERTs" $ do- let- statement :: Manipulation Tables '[] '[]- statement =- insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])- (OnConflictDoUpdate- (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)- (Returning Nil)- statement `manipulationRenders`- "INSERT INTO table1 (col1, col2) VALUES (2, 4)\- \ ON CONFLICT DO UPDATE\- \ SET col1 = 2;"- it "correctly renders returning upsert INSERTs" $ do- let- statement :: Manipulation Tables '[] SumAndCol1- statement =- insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])- (OnConflictDoUpdate- (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)- (Just (#col1 ./= #col2)))- (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- statement `manipulationRenders`- "INSERT INTO table1 (col1, col2) VALUES (2, 4)\- \ ON CONFLICT DO UPDATE\- \ SET col1 = 2\- \ WHERE (col1 <> col2)\- \ RETURNING (col1 + col2) AS sum, col1 AS col1;"- it "correctly renders DELETEs" $ do- let- statement :: Manipulation Tables '[] '[]- statement = deleteFrom #table1 (#col1 .== #col2) (Returning Nil)- statement `manipulationRenders`- "DELETE FROM table1 WHERE (col1 = col2);"- it "should be safe against SQL injection in literal text" $ do- let- statement :: Manipulation StudentsTable '[] '[]- statement = insertInto #students- (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])- OnConflictDoRaise (Returning Nil)- statement `manipulationRenders`- "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"--type Columns =- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4)- ]-type Tables = '[ "table1" ::: Columns ]-type SumAndCol1 =- '[ "sum" ::: 'Required ('NotNull 'PGint4)- , "col1" ::: 'Required ('NotNull 'PGint4)- ]-type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]-type StudentsTable = '["students" ::: StudentsColumns]-type OrderColumns =- '[ "orderID" ::: 'Required ('NotNull 'PGint4)- , "orderVal" ::: 'Required ('NotNull 'PGtext)- , "customerID" ::: 'Required ('NotNull 'PGint4)- , "shipperID" ::: 'Required ('NotNull 'PGint4)- ]-type CustomerColumns =- '[ "customerID" ::: 'Required ('NotNull 'PGint4)- , "customerVal" ::: 'Required ('NotNull 'PGfloat4)- ]-type ShipperColumns =- '[ "shipperID" ::: 'Required ('NotNull 'PGint4)- , "shipperVal" ::: 'Required ('NotNull 'PGbool)- ]-type JoinTables =- '[ "orders" ::: OrderColumns- , "customers" ::: CustomerColumns- , "shippers" ::: ShipperColumns- ]-type ValueColumns =- '[ "orderVal" ::: 'Required ('NotNull 'PGtext)- , "customerVal" ::: 'Required ('NotNull 'PGfloat4)- , "shipperVal" ::: 'Required ('NotNull 'PGbool)- ]
− test/Squeal/PostgreSQL/QuerySpec.hs
@@ -1,181 +0,0 @@-{-# LANGUAGE- DataKinds- , MagicHash- , OverloadedLabels- , OverloadedStrings- , TypeApplications- , TypeOperators-#-}--module Squeal.PostgreSQL.QuerySpec where--import Data.Function-import Generics.SOP hiding (from)-import Test.Hspec--import Squeal.PostgreSQL--spec :: Spec-spec = do- let- qry `queryRenders` str =- renderManipulation (queryStatement qry) `shouldBe` str- it "correctly renders a simple SELECT query" $ do- let- statement :: Query Tables '[] SumAndCol1- statement =- select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- (from (Table (#table1 `As` #table1)) & where_ (#col1 .> #col2))- statement `queryRenders`- "SELECT (col1 + col2) AS sum, col1 AS col1\- \ FROM table1 AS table1 WHERE (col1 > col2);"- it "combines WHEREs using AND" $ do- let- statement :: Query Tables '[] SumAndCol1- statement =- select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- (from (Table (#table1 `As` #table1)) & where_ true & where_ false)- statement `queryRenders`- "SELECT (col1 + col2) AS sum, col1 AS col1\- \ FROM table1 AS table1 WHERE (TRUE AND FALSE);"- it "performs sub SELECTs" $ do- let- statement :: Query Tables '[] SumAndCol1- statement =- selectStar (from (Subquery- (select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)- (from (Table (#table1 `As` #table1))) `As` #sub)))- statement `queryRenders`- "SELECT * FROM\- \ (SELECT (col1 + col2) AS sum, col1 AS col1\- \ FROM table1 AS table1) AS sub;"- it "does LIMIT clauses" $ do- let- statement :: Query Tables '[] Columns- statement = selectStar (from (Table (#table1 `As` #table1)) & limit 1)- statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"- it "should use the minimum of given LIMITs" $ do- let- statement :: Query Tables '[] Columns- statement =- selectStar (from (Table (#table1 `As` #table1)) & limit 1 & limit 2)- statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"- it "should render parameters using $ signs" $ do- let- statement :: Query Tables '[ 'Required ('NotNull 'PGbool)] Columns- statement = selectStar- (from (Table (#table1 `As` #table1)) & where_ (param @1))- statement `queryRenders`- "SELECT * FROM table1 AS table1 WHERE ($1 :: bool);"- it "does OFFSET clauses" $ do- let- statement :: Query Tables '[] Columns- statement =- selectStar (from (Table (#table1 `As` #table1)) & offset 1)- statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 1;"- it "should use the sum of given OFFSETs" $ do- let- statement :: Query Tables '[] Columns- statement = selectStar- (from (Table (#table1 `As` #table1)) & offset 1 & offset 2)- statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 3;"- it "should render GROUP BY and HAVING clauses" $ do- let- statement :: Query Tables '[] SumAndCol1- statement =- select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)- ( from (Table (#table1 `As` #table1))- & group (By #col1 :* Nil) - & having (#col1 + sum_ #col2 .> 1) )- statement `queryRenders`- "SELECT sum(col2) AS sum, col1 AS col1\- \ FROM table1 AS table1\- \ GROUP BY col1\- \ HAVING ((col1 + sum(col2)) > 1);"- describe "JOINs" $ do- it "should render CROSS JOINs" $ do- let- statement :: Query JoinTables '[] ValueColumns- statement = select- ( #orders ! #orderVal `As` #orderVal :*- #customers ! #customerVal `As` #customerVal :*- #shippers ! #shipperVal `As` #shipperVal :* Nil )- ( from (Table (#orders `As` #orders)- & CrossJoin (Table (#customers `As` #customers))- & CrossJoin (Table (#shippers `As` #shippers))) )- statement `queryRenders`- "SELECT\- \ orders.orderVal AS orderVal,\- \ customers.customerVal AS customerVal,\- \ shippers.shipperVal AS shipperVal\- \ FROM orders AS orders\- \ CROSS JOIN customers AS customers\- \ CROSS JOIN shippers AS shippers;"- it "should render INNER JOINs" $ do- let- statement :: Query JoinTables '[] ValueColumns- statement = select- ( (#orders ! #orderVal) `As` #orderVal- :* (#customers ! #customerVal) `As` #customerVal- :* (#shippers ! #shipperVal) `As` #shipperVal :* Nil)- ( from (Table (#orders `As` #orders)- & InnerJoin (Table (#customers `As` #customers))- ((#orders ! #customerID) .== (#customers ! #customerID))- & InnerJoin (Table (#shippers `As` #shippers))- ((#orders ! #shipperID) .== (#shippers ! #shipperID))))- statement `queryRenders`- "SELECT\- \ orders.orderVal AS orderVal,\- \ customers.customerVal AS customerVal,\- \ shippers.shipperVal AS shipperVal\- \ FROM orders AS orders\- \ INNER JOIN customers AS customers\- \ ON (orders.customerID = customers.customerID)\- \ INNER JOIN shippers AS shippers\- \ ON (orders.shipperID = shippers.shipperID);"- it "should render self JOINs" $ do- let- statement :: Query JoinTables '[] OrderColumns- statement = selectDotStar #orders1- (from (Table (#orders `As` #orders1)- & CrossJoin (Table (#orders `As` #orders2))))- statement `queryRenders`- "SELECT orders1.*\- \ FROM orders AS orders1\- \ CROSS JOIN orders AS orders2;"--type Columns =- '[ "col1" ::: 'Required ('NotNull 'PGint4)- , "col2" ::: 'Required ('NotNull 'PGint4)- ]-type Tables = '[ "table1" ::: Columns ]-type SumAndCol1 =- '[ "sum" ::: 'Required ('NotNull 'PGint4)- , "col1" ::: 'Required ('NotNull 'PGint4)- ]-type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]-type StudentsTable = '["students" ::: StudentsColumns]-type OrderColumns =- '[ "orderID" ::: 'Required ('NotNull 'PGint4)- , "orderVal" ::: 'Required ('NotNull 'PGtext)- , "customerID" ::: 'Required ('NotNull 'PGint4)- , "shipperID" ::: 'Required ('NotNull 'PGint4)- ]-type CustomerColumns =- '[ "customerID" ::: 'Required ('NotNull 'PGint4)- , "customerVal" ::: 'Required ('NotNull 'PGfloat4)- ]-type ShipperColumns =- '[ "shipperID" ::: 'Required ('NotNull 'PGint4)- , "shipperVal" ::: 'Required ('NotNull 'PGbool)- ]-type JoinTables =- '[ "orders" ::: OrderColumns- , "customers" ::: CustomerColumns- , "shippers" ::: ShipperColumns- ]-type ValueColumns =- '[ "orderVal" ::: 'Required ('NotNull 'PGtext)- , "customerVal" ::: 'Required ('NotNull 'PGfloat4)- , "shipperVal" ::: 'Required ('NotNull 'PGbool)- ]