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