@@ -34,16 +34,10 @@ module Squeal.PostgreSQL.Definition.Table
3434 , createTableIfNotExists
3535 , dropTable
3636 , dropTableIfExists
37− , TableConstraintExpression (..)
38− , check
39− , unique
40− , primaryKey
41− , foreignKey
42− , ForeignKeyed
43− , OnDeleteClause (..)
44− , OnUpdateClause (..)
4537 , alterTable
38+ , alterTableIfExists
4639 , alterTableRename
40+ , alterTableIfExistsRename
4741 , AlterTable (..)
4842 , addConstraint
4943 , dropConstraint
@@ -57,17 +51,6 @@ module Squeal.PostgreSQL.Definition.Table
5751 , setNotNull
5852 , dropNotNull
5953 , alterType
60− -- * Columns
61− , ColumnTypeExpression (..)
62− , nullable
63− , notNullable
64− , default_
65− , serial2
66− , smallserial
67− , serial4
68− , serial
69− , serial8
70− , bigserial
7154 ) where
7255
7356import Control.DeepSeq
@@ -78,9 +61,9 @@ import qualified Generics.SOP as SOP
7861import qualified GHC.Generics as GHC
7962
8063import Squeal.PostgreSQL.Alias
81−import Squeal.PostgreSQL.Definition (Definition (..))
64+import Squeal.PostgreSQL.Definition
65+import Squeal.PostgreSQL.Definition.Table.Constraint
8266import Squeal.PostgreSQL.Expression
83−import Squeal.PostgreSQL.Expression.Logic
8467import Squeal.PostgreSQL.Expression.Type
8568import Squeal.PostgreSQL.List
8669import Squeal.PostgreSQL.Render
@@ -195,288 +178,6 @@ renderCreation tab columns constraints = renderSQL tab
195178 renderConstraint (constraint `As` alias) =
196179 "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
197180
198−-- | Data types are a way to limit the kind of data that can be stored in a
199−-- table. For many applications, however, the constraint they provide is
200−-- too coarse. For example, a column containing a product price should
201−-- probably only accept positive values. But there is no standard data type
202−-- that accepts only positive numbers. Another issue is that you might want
203−-- to constrain column data with respect to other columns or rows.
204−-- For example, in a table containing product information,
205−-- there should be only one row for each product number.
206−-- `TableConstraint`s give you as much control over the data in your tables
207−-- as you wish. If a user attempts to store data in a column that would
208−-- violate a constraint, an error is raised. This applies
209−-- even if the value came from the default value definition.
210−newtype TableConstraintExpression
211− (sch :: Symbol)
212− (tab :: Symbol)
213− (schemas :: SchemasType)
214− (constraint :: TableConstraint)
215− = UnsafeTableConstraintExpression
216− { renderTableConstraintExpression :: ByteString }
217− deriving (GHC.Generic,Show,Eq,Ord,NFData)
218−instance RenderSQL
219− (TableConstraintExpression sch tab schemas constraint) where
220− renderSQL = renderTableConstraintExpression
221−
222−{-| A `check` constraint is the most generic `TableConstraint` type.
223−It allows you to specify that the value in a certain column must satisfy
224−a Boolean (truth-value) expression.
225−
226−>>> :{
227−type Schema = '[
228− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
229− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
230− "b" ::: 'NoDef :=> 'NotNull 'PGint4
231− ])]
232−:}
233−
234−>>> :{
235−let
236− definition :: Definition (Public '[]) (Public Schema)
237− definition = createTable #tab
238− ( (int & notNullable) `as` #a :*
239− (int & notNullable) `as` #b )
240− ( check (#a :* #b) (#a .> #b) `as` #inequality )
241−:}
242−
243−>>> printSQL definition
244−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
245−-}
246−check
247− :: ( Has sch schemas schema
248− , Has tab schema ('Table table)
249− , HasAll aliases (TableToRow table) subcolumns )
250− => NP Alias aliases
251− -- ^ specify the subcolumns which are getting checked
252− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
253− -- ^ a closed `Condition` on those subcolumns
254− -> TableConstraintExpression sch tab schemas ('Check aliases)
255−check _cols condition = UnsafeTableConstraintExpression $
256− "CHECK" <+> parenthesized (renderSQL condition)
257−
258−{-| A `unique` constraint ensure that the data contained in a column,
259−or a group of columns, is unique among all the rows in the table.
260−
261−>>> :{
262−type Schema = '[
263− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
264− "a" ::: 'NoDef :=> 'Null 'PGint4,
265− "b" ::: 'NoDef :=> 'Null 'PGint4
266− ])]
267−:}
268−
269−>>> :{
270−let
271− definition :: Definition (Public '[]) (Public Schema)
272− definition = createTable #tab
273− ( (int & nullable) `as` #a :*
274− (int & nullable) `as` #b )
275− ( unique (#a :* #b) `as` #uq_a_b )
276−:}
277−
278−>>> printSQL definition
279−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
280−-}
281−unique
282− :: ( Has sch schemas schema
283− , Has tab schema('Table table)
284− , HasAll aliases (TableToRow table) subcolumns )
285− => NP Alias aliases
286− -- ^ specify subcolumns which together are unique for each row
287− -> TableConstraintExpression sch tab schemas ('Unique aliases)
288−unique columns = UnsafeTableConstraintExpression $
289− "UNIQUE" <+> parenthesized (renderSQL columns)
290−
291−{-| A `primaryKey` constraint indicates that a column, or group of columns,
292−can be used as a unique identifier for rows in the table.
293−This requires that the values be both unique and not null.
294−
295−>>> :{
296−type Schema = '[
297− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
298− "id" ::: 'Def :=> 'NotNull 'PGint4,
299− "name" ::: 'NoDef :=> 'NotNull 'PGtext
300− ])]
301−:}
302−
303−>>> :{
304−let
305− definition :: Definition (Public '[]) (Public Schema)
306− definition = createTable #tab
307− ( serial `as` #id :*
308− (text & notNullable) `as` #name )
309− ( primaryKey #id `as` #pk_id )
310−:}
311−
312−>>> printSQL definition
313−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
314−-}
315−primaryKey
316− :: ( Has sch schemas schema
317− , Has tab schema ('Table table)
318− , HasAll aliases (TableToColumns table) subcolumns
319− , AllNotNull subcolumns )
320− => NP Alias aliases
321− -- ^ specify the subcolumns which together form a primary key.
322− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
323−primaryKey columns = UnsafeTableConstraintExpression $
324− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
325−
326−{-| A `foreignKey` specifies that the values in a column
327−(or a group of columns) must match the values appearing in some row of
328−another table. We say this maintains the referential integrity
329−between two related tables.
330−
331−>>> :{
332−type Schema =
333− '[ "users" ::: 'Table (
334− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
335− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
336− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
337− ])
338− , "emails" ::: 'Table (
339− '[ "pk_emails" ::: 'PrimaryKey '["id"]
340− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
341− ] :=>
342− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
343− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
344− , "email" ::: 'NoDef :=> 'Null 'PGtext
345− ])
346− ]
347−:}
348−
349−>>> :{
350−let
351− setup :: Definition (Public '[]) (Public Schema)
352− setup =
353− createTable #users
354− ( serial `as` #id :*
355− (text & notNullable) `as` #name )
356− ( primaryKey #id `as` #pk_users ) >>>
357− createTable #emails
358− ( serial `as` #id :*
359− (int & notNullable) `as` #user_id :*
360− (text & nullable) `as` #email )
361− ( primaryKey #id `as` #pk_emails :*
362− foreignKey #user_id #users #id
363− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
364−in printSQL setup
365−:}
366−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
367−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);
368−
369−A `foreignKey` can even be a table self-reference.
370−
371−>>> :{
372−type Schema =
373− '[ "employees" ::: 'Table (
374− '[ "employees_pk" ::: 'PrimaryKey '["id"]
375− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
376− ] :=>
377− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
378− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
379− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
380− ])
381− ]
382−:}
383−
384−>>> :{
385−let
386− setup :: Definition (Public '[]) (Public Schema)
387− setup =
388− createTable #employees
389− ( serial `as` #id :*
390− (text & notNullable) `as` #name :*
391− (integer & nullable) `as` #employer_id )
392− ( primaryKey #id `as` #employees_pk :*
393− foreignKey #employer_id #employees #id
394− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
395−in printSQL setup
396−:}
397−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);
398−-}
399−foreignKey
400− :: (ForeignKeyed schemas sch schema child parent
401− table reftable
402− columns refcolumns
403− constraints cols
404− reftys tys )
405− => NP Alias columns
406− -- ^ column or columns in the table
407− -> Alias parent
408− -- ^ reference table
409− -> NP Alias refcolumns
410− -- ^ reference column or columns in the reference table
411− -> OnDeleteClause
412− -- ^ what to do when reference is deleted
413− -> OnUpdateClause
414− -- ^ what to do when reference is updated
415− -> TableConstraintExpression sch child schemas
416− ('ForeignKey columns parent refcolumns)
417−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
418− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
419− <+> "REFERENCES" <+> renderSQL parent
420− <+> parenthesized (renderSQL refs)
421− <+> renderSQL ondel
422− <+> renderSQL onupd
423−
424−-- | A constraint synonym between types involved in a foreign key constraint.
425−type ForeignKeyed schemas
426− sch
427− schema
428− child parent
429− table reftable
430− columns refcolumns
431− constraints cols
432− reftys tys =
433− ( Has sch schemas schema
434− , Has child schema ('Table table)
435− , Has parent schema ('Table reftable)
436− , HasAll columns (TableToColumns table) tys
437− , reftable ~ (constraints :=> cols)
438− , HasAll refcolumns cols reftys
439− , SOP.AllZip SamePGType tys reftys
440− , Uniquely refcolumns constraints )
441−
442−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
443−data OnDeleteClause
444− = OnDeleteNoAction
445− -- ^ if any referencing rows still exist when the constraint is checked,
446− -- an error is raised
447− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
448− | OnDeleteCascade
449− -- ^ specifies that when a referenced row is deleted,
450− -- row(s) referencing it should be automatically deleted as well
451− deriving (GHC.Generic,Show,Eq,Ord)
452−instance NFData OnDeleteClause
453−-- | Render `OnDeleteClause`.
454−instance RenderSQL OnDeleteClause where
455− renderSQL = \case
456− OnDeleteNoAction -> "ON DELETE NO ACTION"
457− OnDeleteRestrict -> "ON DELETE RESTRICT"
458− OnDeleteCascade -> "ON DELETE CASCADE"
459−
460−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
461−-- when a referenced column is changed (updated).
462−data OnUpdateClause
463− = OnUpdateNoAction
464− -- ^ if any referencing rows has not changed when the constraint is checked,
465− -- an error is raised
466− | OnUpdateRestrict -- ^ prevents update of a referenced row
467− | OnUpdateCascade
468− -- ^ the updated values of the referenced column(s) should be copied
469− -- into the referencing row(s)
470− deriving (GHC.Generic,Show,Eq,Ord)
471−instance NFData OnUpdateClause
472−
473−-- | Render `OnUpdateClause`.
474−instance RenderSQL OnUpdateClause where
475− renderSQL = \case
476− OnUpdateNoAction -> "ON UPDATE NO ACTION"
477− OnUpdateRestrict -> "ON UPDATE RESTRICT"
478− OnUpdateCascade -> "ON UPDATE CASCADE"
479−
480181-- | `dropTable` removes a table from the schema.
481182--
482183-- >>> :{
@@ -496,35 +197,56 @@ dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
496197
497198dropTableIfExists
498199 :: ( Has sch schemas schema
499− , Has tab schema ('Table table))
200+ , KnownSymbol tab)
500201 => QualifiedAlias sch tab -- ^ table to remove
501− -> Definition schemas (Alter sch (DropIfExists tab schema) schemas)
202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
502203dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
503204
504205-- | `alterTable` changes the definition of a table from the schema.
505206alterTable
506− :: (Has sch schemas schema, Has tab schema ('Table table0))
207+ :: (Has sch schemas schema, KnownSymbol tab)
507208 => QualifiedAlias sch tab -- ^ table to alter
508− -> AlterTable sch tab schemas table1 -- ^ alteration to perform
509− -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
209+ -> AlterTable sch tab schemas table -- ^ alteration to perform
210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
510211alterTable tab alteration = UnsafeDefinition $
511212 "ALTER TABLE"
512213 <+> renderSQL tab
513214 <+> renderAlterTable alteration
514215 <> ";"
515216
217+-- | `alterTable` changes the definition of a table from the schema.
218+alterTableIfExists
219+ :: (Has sch schemas schema, KnownSymbol tab)
220+ => QualifiedAlias sch tab -- ^ table to alter
221+ -> AlterTable sch tab schemas table -- ^ alteration to perform
222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223+alterTableIfExists tab alteration = UnsafeDefinition $
224+ "ALTER TABLE IF EXISTS"
225+ <+> renderSQL tab
226+ <+> renderAlterTable alteration
227+ <> ";"
228+
516229-- | `alterTableRename` changes the name of a table from the schema.
517230--
518231-- >>> printSQL $ alterTableRename #foo #bar
519232-- ALTER TABLE "foo" RENAME TO "bar";
520233alterTableRename
521− :: (KnownSymbol table0, KnownSymbol table1)
522− => Alias table0 -- ^ table to rename
523− -> Alias table1 -- ^ what to rename it
524− -> Definition schema (Rename table0 table1 schema)
525−alterTableRename table0 table1 = UnsafeDefinition $
526− "ALTER TABLE" <+> renderSQL table0
527− <+> "RENAME TO" <+> renderSQL table1 <> ";"
234+ :: (KnownSymbol tab0, KnownSymbol tab1)
235+ => Alias tab0 -- ^ table to rename
236+ -> Alias tab1 -- ^ what to rename it
237+ -> Definition schema (Rename tab0 tab1 schema)
238+alterTableRename tab0 tab1 = UnsafeDefinition $
239+ "ALTER TABLE" <+> renderSQL tab0
240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241+
242+alterTableIfExistsRename
243+ :: (KnownSymbol tab0, KnownSymbol tab1)
244+ => Alias tab0 -- ^ table to rename
245+ -> Alias tab1 -- ^ what to rename it
246+ -> Definition schema (RenameIfExists tab0 tab1 schema)
247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
528250
529251-- | An `AlterTable` describes the alteration to perform on the columns
530252-- of a table.
@@ -776,51 +498,3 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
776498-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
777499alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
778500alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
779−
780−-- | `ColumnTypeExpression`s are used in `createTable` commands.
781−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
782− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
783− deriving (GHC.Generic,Show,Eq,Ord,NFData)
784−instance RenderSQL (ColumnTypeExpression schemas ty) where
785− renderSQL = renderColumnTypeExpression
786−
787−-- | used in `createTable` commands as a column constraint to note that
788−-- @NULL@ may be present in a column
789−nullable
790− :: TypeExpression schemas (nullity ty)
791− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
792−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
793−
794−-- | used in `createTable` commands as a column constraint to ensure
795−-- @NULL@ is not present in a column
796−notNullable
797− :: TypeExpression schemas (nullity ty)
798− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
799−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
800−
801−-- | used in `createTable` commands as a column constraint to give a default
802−default_
803− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
804− -> ColumnTypeExpression schemas ('NoDef :=> ty)
805− -> ColumnTypeExpression schemas ('Def :=> ty)
806−default_ x ty = UnsafeColumnTypeExpression $
807− renderSQL ty <+> "DEFAULT" <+> renderExpression x
808−
809−-- | not a true type, but merely a notational convenience for creating
810−-- unique identifier columns with type `PGint2`
811−serial2, smallserial
812− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
813−serial2 = UnsafeColumnTypeExpression "serial2"
814−smallserial = UnsafeColumnTypeExpression "smallserial"
815−-- | not a true type, but merely a notational convenience for creating
816−-- unique identifier columns with type `PGint4`
817−serial4, serial
818− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
819−serial4 = UnsafeColumnTypeExpression "serial4"
820−serial = UnsafeColumnTypeExpression "serial"
821−-- | not a true type, but merely a notational convenience for creating
822−-- unique identifier columns with type `PGint8`
823−serial8, bigserial
824− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
825−serial8 = UnsafeColumnTypeExpression "serial8"
826−bigserial = UnsafeColumnTypeExpression "bigserial"