@@ -27,7 +27,6 @@ Squeal data definition language.
2727 , TypeInType
2828 , TypeOperators
2929 , UndecidableSuperClasses
30− , UndecidableInstances
3130#-}
3231
3332module Squeal.PostgreSQL.Definition
@@ -35,16 +34,103 @@ module Squeal.PostgreSQL.Definition
3534 Definition (..)
3635 , (>>>)
3736 , manipDefinition
37+ -- * Tables
38+ -- ** Create
39+ , createSchema
40+ , createSchemaIfNotExists
41+ , createTable
42+ , createTableIfNotExists
43+ , createView
44+ , createOrReplaceView
45+ , createTypeEnum
46+ , createTypeEnumFrom
47+ , createTypeComposite
48+ , createTypeCompositeFrom
49+ , FieldTyped (..)
50+ , createDomain
51+ , createTypeRange
52+ , createIndex
53+ , createIndexIfNotExists
54+ , IndexMethod (..)
55+ , btree, hash, gist, spgist, gin, brin
56+ , createFunction
57+ , createOrReplaceFunction
58+ , createSetFunction
59+ , createOrReplaceSetFunction
60+ , createBinaryOp
61+ , createLeftOp
62+ , createRightOp
63+ , TableConstraintExpression (..)
64+ , check
65+ , unique
66+ , primaryKey
67+ , foreignKey
68+ , ForeignKeyed
69+ , OnDeleteClause (..)
70+ , OnUpdateClause (..)
71+ , FunctionDefinition(..)
72+ , languageSqlExpr
73+ , languageSqlQuery
74+ -- ** Drop
75+ , dropSchema
76+ , dropSchemaIfExists
77+ , dropTable
78+ , dropTableIfExists
79+ , dropView
80+ , dropViewIfExists
81+ , dropType
82+ , dropTypeIfExists
83+ , dropIndex
84+ , dropIndexIfExists
85+ , dropFunction
86+ , dropOperator
87+ -- ** Alter
88+ , alterTable
89+ , alterTableRename
90+ , AlterTable (..)
91+ , addConstraint
92+ , dropConstraint
93+ , AddColumn (..)
94+ , dropColumn
95+ , renameColumn
96+ , alterColumn
97+ , AlterColumn (..)
98+ , setDefault
99+ , dropDefault
100+ , setNotNull
101+ , dropNotNull
102+ , alterType
103+ -- * Columns
104+ , ColumnTypeExpression (..)
105+ , nullable
106+ , notNullable
107+ , default_
108+ , serial2
109+ , smallserial
110+ , serial4
111+ , serial
112+ , serial8
113+ , bigserial
38114 ) where
39115
40116import Control.Category
41117import Control.DeepSeq
42118import Data.ByteString
43119import Data.Monoid
120+import GHC.TypeLits
44121import Prelude hiding ((.), id)
45122
123+import qualified Generics.SOP as SOP
46124import qualified GHC.Generics as GHC
47125
126+import Squeal.PostgreSQL.Alias
127+import Squeal.PostgreSQL.Expression
128+import Squeal.PostgreSQL.Expression.Logic
129+import Squeal.PostgreSQL.Expression.Sort
130+import Squeal.PostgreSQL.Expression.Type
131+import Squeal.PostgreSQL.List
132+import Squeal.PostgreSQL.PG
133+import Squeal.PostgreSQL.Query
48134import Squeal.PostgreSQL.Manipulation
49135import Squeal.PostgreSQL.Render
50136import Squeal.PostgreSQL.Schema
@@ -80,3 +166,1288 @@ manipDefinition
80166 -- ^ no input or output
81167 -> Definition schemas schemas
82168manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
169+
170+{-----------------------------------------
171+CREATE statements
172+-----------------------------------------}
173+
174+{- |
175+`createSchema` enters a new schema into the current database.
176+The schema name must be distinct from the name of any existing schema
177+in the current database.
178+
179+A schema is essentially a namespace: it contains named objects
180+(tables, data types, functions, and operators) whose names
181+can duplicate those of other objects existing in other schemas.
182+Named objects are accessed by `QualifiedAlias`es with the schema
183+name as a prefix.
184+-}
185+createSchema
186+ :: KnownSymbol sch
187+ => Alias sch
188+ -> Definition schemas (Create sch '[] schemas)
189+createSchema sch = UnsafeDefinition $
190+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
191+
192+{- | Idempotent version of `createSchema`. -}
193+createSchemaIfNotExists
194+ :: (KnownSymbol sch, Has sch schemas schema)
195+ => Alias sch
196+ -> Definition schemas (CreateIfNotExists sch '[] schemas)
197+createSchemaIfNotExists sch = UnsafeDefinition $
198+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
199+ <+> renderSQL sch <> ";"
200+
201+{- | `createTable` adds a table to the schema.
202+
203+>>> :set -XOverloadedLabels
204+>>> :{
205+type Table = '[] :=>
206+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
207+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
208+:}
209+
210+>>> :{
211+let
212+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
213+ setup = createTable #tab
214+ (nullable int `as` #a :* nullable real `as` #b) Nil
215+in printSQL setup
216+:}
217+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
218+-}
219+createTable
220+ :: ( KnownSymbol sch
221+ , KnownSymbol tab
222+ , columns ~ (col ': cols)
223+ , SOP.SListI columns
224+ , SOP.SListI constraints
225+ , Has sch schemas0 schema0
226+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
227+ => QualifiedAlias sch tab -- ^ the name of the table to add
228+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
229+ -- ^ the names and datatype of each column
230+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
231+ -- ^ constraints that must hold for the table
232+ -> Definition schemas0 schemas1
233+createTable tab columns constraints = UnsafeDefinition $
234+ "CREATE TABLE" <+> renderCreation tab columns constraints
235+
236+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
237+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
238+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
239+the `Category` of `Definition`s.
240+
241+>>> :set -XOverloadedLabels -XTypeApplications
242+>>> :{
243+type Table = '[] :=>
244+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
245+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
246+:}
247+
248+>>> type Schemas = Public '["tab" ::: 'Table Table]
249+
250+>>> :{
251+let
252+ setup :: Definition Schemas Schemas
253+ setup = createTableIfNotExists #tab
254+ (nullable int `as` #a :* nullable real `as` #b) Nil
255+in printSQL setup
256+:}
257+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
258+-}
259+createTableIfNotExists
260+ :: ( KnownSymbol sch
261+ , KnownSymbol tab
262+ , columns ~ (col ': cols)
263+ , SOP.SListI columns
264+ , SOP.SListI constraints
265+ , Has sch schemas0 schema0
266+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
267+ => QualifiedAlias sch tab -- ^ the name of the table to add
268+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
269+ -- ^ the names and datatype of each column
270+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
271+ -- ^ constraints that must hold for the table
272+ -> Definition schemas0 schemas1
273+createTableIfNotExists tab columns constraints = UnsafeDefinition $
274+ "CREATE TABLE IF NOT EXISTS"
275+ <+> renderCreation tab columns constraints
276+
277+-- helper function for `createTable` and `createTableIfNotExists`
278+renderCreation
279+ :: ( KnownSymbol sch
280+ , KnownSymbol tab
281+ , SOP.SListI columns
282+ , SOP.SListI constraints )
283+ => QualifiedAlias sch tab -- ^ the name of the table to add
284+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
285+ -- ^ the names and datatype of each column
286+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
287+ -- ^ constraints that must hold for the table
288+ -> ByteString
289+renderCreation tab columns constraints = renderSQL tab
290+ <+> parenthesized
291+ ( renderCommaSeparated renderColumnDef columns
292+ <> ( case constraints of
293+ Nil -> ""
294+ _ -> ", " <>
295+ renderCommaSeparated renderConstraint constraints ) )
296+ <> ";"
297+ where
298+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
299+ renderColumnDef (ty `As` column) =
300+ renderSQL column <+> renderColumnTypeExpression ty
301+ renderConstraint
302+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
303+ -> ByteString
304+ renderConstraint (constraint `As` alias) =
305+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
306+
307+-- | Data types are a way to limit the kind of data that can be stored in a
308+-- table. For many applications, however, the constraint they provide is
309+-- too coarse. For example, a column containing a product price should
310+-- probably only accept positive values. But there is no standard data type
311+-- that accepts only positive numbers. Another issue is that you might want
312+-- to constrain column data with respect to other columns or rows.
313+-- For example, in a table containing product information,
314+-- there should be only one row for each product number.
315+-- `TableConstraint`s give you as much control over the data in your tables
316+-- as you wish. If a user attempts to store data in a column that would
317+-- violate a constraint, an error is raised. This applies
318+-- even if the value came from the default value definition.
319+newtype TableConstraintExpression
320+ (sch :: Symbol)
321+ (tab :: Symbol)
322+ (schemas :: SchemasType)
323+ (constraint :: TableConstraint)
324+ = UnsafeTableConstraintExpression
325+ { renderTableConstraintExpression :: ByteString }
326+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
327+instance RenderSQL
328+ (TableConstraintExpression sch tab schemas constraint) where
329+ renderSQL = renderTableConstraintExpression
330+
331+{-| A `check` constraint is the most generic `TableConstraint` type.
332+It allows you to specify that the value in a certain column must satisfy
333+a Boolean (truth-value) expression.
334+
335+>>> :{
336+type Schema = '[
337+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
338+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
339+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
340+ ])]
341+:}
342+
343+>>> :{
344+let
345+ definition :: Definition (Public '[]) (Public Schema)
346+ definition = createTable #tab
347+ ( (int & notNullable) `as` #a :*
348+ (int & notNullable) `as` #b )
349+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
350+:}
351+
352+>>> printSQL definition
353+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
354+-}
355+check
356+ :: ( Has sch schemas schema
357+ , Has tab schema ('Table table)
358+ , HasAll aliases (TableToRow table) subcolumns )
359+ => NP Alias aliases
360+ -- ^ specify the subcolumns which are getting checked
361+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
362+ -- ^ a closed `Condition` on those subcolumns
363+ -> TableConstraintExpression sch tab schemas ('Check aliases)
364+check _cols condition = UnsafeTableConstraintExpression $
365+ "CHECK" <+> parenthesized (renderSQL condition)
366+
367+{-| A `unique` constraint ensure that the data contained in a column,
368+or a group of columns, is unique among all the rows in the table.
369+
370+>>> :{
371+type Schema = '[
372+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
373+ "a" ::: 'NoDef :=> 'Null 'PGint4,
374+ "b" ::: 'NoDef :=> 'Null 'PGint4
375+ ])]
376+:}
377+
378+>>> :{
379+let
380+ definition :: Definition (Public '[]) (Public Schema)
381+ definition = createTable #tab
382+ ( (int & nullable) `as` #a :*
383+ (int & nullable) `as` #b )
384+ ( unique (#a :* #b) `as` #uq_a_b )
385+:}
386+
387+>>> printSQL definition
388+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
389+-}
390+unique
391+ :: ( Has sch schemas schema
392+ , Has tab schema('Table table)
393+ , HasAll aliases (TableToRow table) subcolumns )
394+ => NP Alias aliases
395+ -- ^ specify subcolumns which together are unique for each row
396+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
397+unique columns = UnsafeTableConstraintExpression $
398+ "UNIQUE" <+> parenthesized (renderSQL columns)
399+
400+{-| A `primaryKey` constraint indicates that a column, or group of columns,
401+can be used as a unique identifier for rows in the table.
402+This requires that the values be both unique and not null.
403+
404+>>> :{
405+type Schema = '[
406+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
407+ "id" ::: 'Def :=> 'NotNull 'PGint4,
408+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
409+ ])]
410+:}
411+
412+>>> :{
413+let
414+ definition :: Definition (Public '[]) (Public Schema)
415+ definition = createTable #tab
416+ ( serial `as` #id :*
417+ (text & notNullable) `as` #name )
418+ ( primaryKey #id `as` #pk_id )
419+:}
420+
421+>>> printSQL definition
422+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
423+-}
424+primaryKey
425+ :: ( Has sch schemas schema
426+ , Has tab schema ('Table table)
427+ , HasAll aliases (TableToColumns table) subcolumns
428+ , AllNotNull subcolumns )
429+ => NP Alias aliases
430+ -- ^ specify the subcolumns which together form a primary key.
431+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
432+primaryKey columns = UnsafeTableConstraintExpression $
433+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
434+
435+{-| A `foreignKey` specifies that the values in a column
436+(or a group of columns) must match the values appearing in some row of
437+another table. We say this maintains the referential integrity
438+between two related tables.
439+
440+>>> :{
441+type Schema =
442+ '[ "users" ::: 'Table (
443+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
444+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
445+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
446+ ])
447+ , "emails" ::: 'Table (
448+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
449+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
450+ ] :=>
451+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
452+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
453+ , "email" ::: 'NoDef :=> 'Null 'PGtext
454+ ])
455+ ]
456+:}
457+
458+>>> :{
459+let
460+ setup :: Definition (Public '[]) (Public Schema)
461+ setup =
462+ createTable #users
463+ ( serial `as` #id :*
464+ (text & notNullable) `as` #name )
465+ ( primaryKey #id `as` #pk_users ) >>>
466+ createTable #emails
467+ ( serial `as` #id :*
468+ (int & notNullable) `as` #user_id :*
469+ (text & nullable) `as` #email )
470+ ( primaryKey #id `as` #pk_emails :*
471+ foreignKey #user_id #users #id
472+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
473+in printSQL setup
474+:}
475+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
476+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);
477+
478+A `foreignKey` can even be a table self-reference.
479+
480+>>> :{
481+type Schema =
482+ '[ "employees" ::: 'Table (
483+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
484+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
485+ ] :=>
486+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
487+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
488+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
489+ ])
490+ ]
491+:}
492+
493+>>> :{
494+let
495+ setup :: Definition (Public '[]) (Public Schema)
496+ setup =
497+ createTable #employees
498+ ( serial `as` #id :*
499+ (text & notNullable) `as` #name :*
500+ (integer & nullable) `as` #employer_id )
501+ ( primaryKey #id `as` #employees_pk :*
502+ foreignKey #employer_id #employees #id
503+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
504+in printSQL setup
505+:}
506+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);
507+-}
508+foreignKey
509+ :: (ForeignKeyed schemas sch schema child parent
510+ table reftable
511+ columns refcolumns
512+ constraints cols
513+ reftys tys )
514+ => NP Alias columns
515+ -- ^ column or columns in the table
516+ -> Alias parent
517+ -- ^ reference table
518+ -> NP Alias refcolumns
519+ -- ^ reference column or columns in the reference table
520+ -> OnDeleteClause
521+ -- ^ what to do when reference is deleted
522+ -> OnUpdateClause
523+ -- ^ what to do when reference is updated
524+ -> TableConstraintExpression sch child schemas
525+ ('ForeignKey columns parent refcolumns)
526+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
527+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
528+ <+> "REFERENCES" <+> renderSQL parent
529+ <+> parenthesized (renderSQL refs)
530+ <+> renderSQL ondel
531+ <+> renderSQL onupd
532+
533+-- | A constraint synonym between types involved in a foreign key constraint.
534+type ForeignKeyed schemas
535+ sch
536+ schema
537+ child parent
538+ table reftable
539+ columns refcolumns
540+ constraints cols
541+ reftys tys =
542+ ( Has sch schemas schema
543+ , Has child schema ('Table table)
544+ , Has parent schema ('Table reftable)
545+ , HasAll columns (TableToColumns table) tys
546+ , reftable ~ (constraints :=> cols)
547+ , HasAll refcolumns cols reftys
548+ , SOP.AllZip SamePGType tys reftys
549+ , Uniquely refcolumns constraints )
550+
551+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
552+data OnDeleteClause
553+ = OnDeleteNoAction
554+ -- ^ if any referencing rows still exist when the constraint is checked,
555+ -- an error is raised
556+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
557+ | OnDeleteCascade
558+ -- ^ specifies that when a referenced row is deleted,
559+ -- row(s) referencing it should be automatically deleted as well
560+ deriving (GHC.Generic,Show,Eq,Ord)
561+instance NFData OnDeleteClause
562+-- | Render `OnDeleteClause`.
563+instance RenderSQL OnDeleteClause where
564+ renderSQL = \case
565+ OnDeleteNoAction -> "ON DELETE NO ACTION"
566+ OnDeleteRestrict -> "ON DELETE RESTRICT"
567+ OnDeleteCascade -> "ON DELETE CASCADE"
568+
569+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
570+-- when a referenced column is changed (updated).
571+data OnUpdateClause
572+ = OnUpdateNoAction
573+ -- ^ if any referencing rows has not changed when the constraint is checked,
574+ -- an error is raised
575+ | OnUpdateRestrict -- ^ prevents update of a referenced row
576+ | OnUpdateCascade
577+ -- ^ the updated values of the referenced column(s) should be copied
578+ -- into the referencing row(s)
579+ deriving (GHC.Generic,Show,Eq,Ord)
580+instance NFData OnUpdateClause
581+
582+-- | Render `OnUpdateClause`.
583+instance RenderSQL OnUpdateClause where
584+ renderSQL = \case
585+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
586+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
587+ OnUpdateCascade -> "ON UPDATE CASCADE"
588+
589+{-----------------------------------------
590+DROP statements
591+-----------------------------------------}
592+
593+-- | >>> :{
594+-- let
595+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
596+-- definition = dropSchema #muh_schema
597+-- :}
598+--
599+-- >>> printSQL definition
600+-- DROP SCHEMA "muh_schema";
601+dropSchema
602+ :: KnownSymbol sch
603+ => Alias sch
604+ -- ^ user defined schema
605+ -> Definition schemas (Drop sch schemas)
606+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
607+
608+dropSchemaIfExists
609+ :: KnownSymbol sch
610+ => Alias sch
611+ -- ^ user defined schema
612+ -> Definition schemas (DropIfExists sch schemas)
613+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
614+
615+-- | `dropTable` removes a table from the schema.
616+--
617+-- >>> :{
618+-- let
619+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
620+-- definition = dropTable #muh_table
621+-- :}
622+--
623+-- >>> printSQL definition
624+-- DROP TABLE "muh_table";
625+dropTable
626+ :: ( Has sch schemas schema
627+ , KnownSymbol tab )
628+ => QualifiedAlias sch tab -- ^ table to remove
629+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
630+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
631+
632+dropTableIfExists
633+ :: ( Has sch schemas schema
634+ , Has tab schema ('Table table))
635+ => QualifiedAlias sch tab -- ^ table to remove
636+ -> Definition schemas (Alter sch (DropIfExists tab schema) schemas)
637+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
638+
639+{-----------------------------------------
640+ALTER statements
641+-----------------------------------------}
642+
643+-- | `alterTable` changes the definition of a table from the schema.
644+alterTable
645+ :: (Has sch schemas schema, Has tab schema ('Table table0))
646+ => QualifiedAlias sch tab -- ^ table to alter
647+ -> AlterTable sch tab schemas table1 -- ^ alteration to perform
648+ -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
649+alterTable tab alteration = UnsafeDefinition $
650+ "ALTER TABLE"
651+ <+> renderSQL tab
652+ <+> renderAlterTable alteration
653+ <> ";"
654+
655+-- | `alterTableRename` changes the name of a table from the schema.
656+--
657+-- >>> printSQL $ alterTableRename #foo #bar
658+-- ALTER TABLE "foo" RENAME TO "bar";
659+alterTableRename
660+ :: (KnownSymbol table0, KnownSymbol table1)
661+ => Alias table0 -- ^ table to rename
662+ -> Alias table1 -- ^ what to rename it
663+ -> Definition schema (Rename table0 table1 schema)
664+alterTableRename table0 table1 = UnsafeDefinition $
665+ "ALTER TABLE" <+> renderSQL table0
666+ <+> "RENAME TO" <+> renderSQL table1 <> ";"
667+
668+-- | An `AlterTable` describes the alteration to perform on the columns
669+-- of a table.
670+newtype AlterTable
671+ (sch :: Symbol)
672+ (tab :: Symbol)
673+ (schemas :: SchemasType)
674+ (table :: TableType) =
675+ UnsafeAlterTable {renderAlterTable :: ByteString}
676+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
677+
678+-- | An `addConstraint` adds a table constraint.
679+--
680+-- >>> :{
681+-- let
682+-- definition :: Definition
683+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
684+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
685+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
686+-- in printSQL definition
687+-- :}
688+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
689+addConstraint
690+ :: ( KnownSymbol alias
691+ , Has sch schemas schema
692+ , Has tab schema ('Table table0)
693+ , table0 ~ (constraints :=> columns)
694+ , table1 ~ (Create alias constraint constraints :=> columns) )
695+ => Alias alias
696+ -> TableConstraintExpression sch tab schemas constraint
697+ -- ^ constraint to add
698+ -> AlterTable sch tab schemas table1
699+addConstraint alias constraint = UnsafeAlterTable $
700+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
701+ <+> renderSQL constraint
702+
703+-- | A `dropConstraint` drops a table constraint.
704+--
705+-- >>> :{
706+-- let
707+-- definition :: Definition
708+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
709+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
710+-- definition = alterTable #tab (dropConstraint #positive)
711+-- in printSQL definition
712+-- :}
713+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
714+dropConstraint
715+ :: ( KnownSymbol constraint
716+ , Has sch schemas schema
717+ , Has tab schema ('Table table0)
718+ , table0 ~ (constraints :=> columns)
719+ , table1 ~ (Drop constraint constraints :=> columns) )
720+ => Alias constraint
721+ -- ^ constraint to drop
722+ -> AlterTable sch tab schemas table1
723+dropConstraint constraint = UnsafeAlterTable $
724+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
725+
726+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
727+class AddColumn ty where
728+ -- | `addColumn` adds a new column, initially filled with whatever
729+ -- default value is given or with @NULL@.
730+ --
731+ -- >>> :{
732+ -- let
733+ -- definition :: Definition
734+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
735+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
736+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
737+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
738+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
739+ -- in printSQL definition
740+ -- :}
741+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
742+ --
743+ -- >>> :{
744+ -- let
745+ -- definition :: Definition
746+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
747+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
748+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
749+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
750+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
751+ -- in printSQL definition
752+ -- :}
753+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
754+ addColumn
755+ :: ( KnownSymbol column
756+ , Has sch schemas schema
757+ , Has tab schema ('Table table0)
758+ , table0 ~ (constraints :=> columns) )
759+ => Alias column -- ^ column to add
760+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
761+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
762+ addColumn column ty = UnsafeAlterTable $
763+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
764+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
765+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
766+
767+-- | A `dropColumn` removes a column. Whatever data was in the column
768+-- disappears. Table constraints involving the column are dropped, too.
769+-- However, if the column is referenced by a foreign key constraint of
770+-- another table, PostgreSQL will not silently drop that constraint.
771+--
772+-- >>> :{
773+-- let
774+-- definition :: Definition
775+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
776+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
777+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
778+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
779+-- definition = alterTable #tab (dropColumn #col2)
780+-- in printSQL definition
781+-- :}
782+-- ALTER TABLE "tab" DROP COLUMN "col2";
783+dropColumn
784+ :: ( KnownSymbol column
785+ , Has sch schemas schema
786+ , Has tab schema ('Table table0)
787+ , table0 ~ (constraints :=> columns)
788+ , table1 ~ (constraints :=> Drop column columns) )
789+ => Alias column -- ^ column to remove
790+ -> AlterTable sch tab schemas table1
791+dropColumn column = UnsafeAlterTable $
792+ "DROP COLUMN" <+> renderSQL column
793+
794+-- | A `renameColumn` renames a column.
795+--
796+-- >>> :{
797+-- let
798+-- definition :: Definition
799+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
800+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
801+-- definition = alterTable #tab (renameColumn #foo #bar)
802+-- in printSQL definition
803+-- :}
804+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
805+renameColumn
806+ :: ( KnownSymbol column0
807+ , KnownSymbol column1
808+ , Has sch schemas schema
809+ , Has tab schema ('Table table0)
810+ , table0 ~ (constraints :=> columns)
811+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
812+ => Alias column0 -- ^ column to rename
813+ -> Alias column1 -- ^ what to rename the column
814+ -> AlterTable sch tab schemas table1
815+renameColumn column0 column1 = UnsafeAlterTable $
816+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
817+
818+-- | An `alterColumn` alters a single column.
819+alterColumn
820+ :: ( KnownSymbol column
821+ , Has sch schemas schema
822+ , Has tab schema ('Table table0)
823+ , table0 ~ (constraints :=> columns)
824+ , Has column columns ty0
825+ , table1 ~ (constraints :=> Alter column ty1 columns))
826+ => Alias column -- ^ column to alter
827+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
828+ -> AlterTable sch tab schemas table1
829+alterColumn column alteration = UnsafeAlterTable $
830+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
831+
832+-- | An `AlterColumn` describes the alteration to perform on a single column.
833+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
834+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
835+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
836+
837+-- | A `setDefault` sets a new default for a column. Note that this doesn't
838+-- affect any existing rows in the table, it just changes the default for
839+-- future insert and update commands.
840+--
841+-- >>> :{
842+-- let
843+-- definition :: Definition
844+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
845+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
846+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
847+-- in printSQL definition
848+-- :}
849+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
850+setDefault
851+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
852+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
853+setDefault expression = UnsafeAlterColumn $
854+ "SET DEFAULT" <+> renderExpression expression
855+
856+-- | A `dropDefault` removes any default value for a column.
857+--
858+-- >>> :{
859+-- let
860+-- definition :: Definition
861+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
862+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
863+-- definition = alterTable #tab (alterColumn #col dropDefault)
864+-- in printSQL definition
865+-- :}
866+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
867+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
868+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
869+
870+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
871+-- The constraint will be checked immediately, so the table data must satisfy
872+-- the constraint before it can be added.
873+--
874+-- >>> :{
875+-- let
876+-- definition :: Definition
877+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
878+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
879+-- definition = alterTable #tab (alterColumn #col setNotNull)
880+-- in printSQL definition
881+-- :}
882+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
883+setNotNull
884+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
885+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
886+
887+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
888+--
889+-- >>> :{
890+-- let
891+-- definition :: Definition
892+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
893+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
894+-- definition = alterTable #tab (alterColumn #col dropNotNull)
895+-- in printSQL definition
896+-- :}
897+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
898+dropNotNull
899+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
900+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
901+
902+-- | An `alterType` converts a column to a different data type.
903+-- This will succeed only if each existing entry in the column can be
904+-- converted to the new type by an implicit cast.
905+--
906+-- >>> :{
907+-- let
908+-- definition :: Definition
909+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
910+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
911+-- definition =
912+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
913+-- in printSQL definition
914+-- :}
915+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
916+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
917+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
918+
919+{- | Create a view.
920+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
921+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
922+>>> :{
923+let
924+ definition :: Definition
925+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
926+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
927+ definition =
928+ createView #bc (select_ (#b :* #c) (from (table #abc)))
929+in printSQL definition
930+:}
931+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
932+-}
933+createView
934+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
935+ => QualifiedAlias sch vw -- ^ the name of the view to add
936+ -> Query '[] '[] schemas '[] view -- ^ query
937+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
938+createView alias query = UnsafeDefinition $
939+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
940+ <+> renderQuery query <> ";"
941+
942+
943+createOrReplaceView
944+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
945+ => QualifiedAlias sch vw -- ^ the name of the view to add
946+ -> Query '[] '[] schemas '[] view -- ^ query
947+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
948+createOrReplaceView alias query = UnsafeDefinition $
949+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
950+ <+> renderQuery query <> ";"
951+
952+-- | Drop a view.
953+--
954+-- >>> :{
955+-- let
956+-- definition :: Definition
957+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
958+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
959+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
960+-- definition = dropView #bc
961+-- in printSQL definition
962+-- :}
963+-- DROP VIEW "bc";
964+dropView
965+ :: (Has sch schemas schema, KnownSymbol vw)
966+ => QualifiedAlias sch vw -- ^ view to remove
967+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
968+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
969+
970+dropViewIfExists
971+ :: (Has sch schemas schema, KnownSymbol vw)
972+ => QualifiedAlias sch vw -- ^ view to remove
973+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
974+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
975+
976+-- | Enumerated types are created using the `createTypeEnum` command, for example
977+--
978+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
979+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
980+createTypeEnum
981+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
982+ => QualifiedAlias sch enum
983+ -- ^ name of the user defined enumerated type
984+ -> NP PGlabel labels
985+ -- ^ labels of the enumerated type
986+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
987+createTypeEnum enum labels = UnsafeDefinition $
988+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
989+ parenthesized (renderSQL labels) <> ";"
990+
991+-- | Enumerated types can also be generated from a Haskell type, for example
992+--
993+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
994+-- >>> instance SOP.Generic Schwarma
995+-- >>> instance SOP.HasDatatypeInfo Schwarma
996+-- >>> :{
997+-- let
998+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
999+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
1000+-- in
1001+-- printSQL createSchwarma
1002+-- :}
1003+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
1004+createTypeEnumFrom
1005+ :: forall hask sch enum schemas schema.
1006+ ( SOP.Generic hask
1007+ , SOP.All KnownSymbol (LabelsPG hask)
1008+ , KnownSymbol enum
1009+ , Has sch schemas schema )
1010+ => QualifiedAlias sch enum
1011+ -- ^ name of the user defined enumerated type
1012+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
1013+createTypeEnumFrom enum = createTypeEnum enum
1014+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
1015+
1016+{- | `createTypeComposite` creates a composite type. The composite type is
1017+specified by a list of attribute names and data types.
1018+
1019+>>> :{
1020+type PGcomplex = 'PGcomposite
1021+ '[ "real" ::: 'NotNull 'PGfloat8
1022+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
1023+:}
1024+
1025+>>> :{
1026+let
1027+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
1028+ setup = createTypeComposite #complex
1029+ (float8 `as` #real :* float8 `as` #imaginary)
1030+in printSQL setup
1031+:}
1032+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
1033+-}
1034+createTypeComposite
1035+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
1036+ => QualifiedAlias sch ty
1037+ -- ^ name of the user defined composite type
1038+ -> NP (Aliased (TypeExpression schemas)) fields
1039+ -- ^ list of attribute names and data types
1040+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
1041+createTypeComposite ty fields = UnsafeDefinition $
1042+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
1043+ (renderCommaSeparated renderField fields) <> ";"
1044+ where
1045+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
1046+ renderField (typ `As` alias) =
1047+ renderSQL alias <+> renderSQL typ
1048+
1049+-- | Composite types can also be generated from a Haskell type, for example
1050+--
1051+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
1052+-- >>> instance SOP.Generic Complex
1053+-- >>> instance SOP.HasDatatypeInfo Complex
1054+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
1055+-- >>> :{
1056+-- let
1057+-- createComplex :: Definition (Public '[]) (Public Schema)
1058+-- createComplex = createTypeCompositeFrom @Complex #complex
1059+-- in
1060+-- printSQL createComplex
1061+-- :}
1062+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
1063+createTypeCompositeFrom
1064+ :: forall hask sch ty schemas schema.
1065+ ( SOP.All (FieldTyped schemas) (RowPG hask)
1066+ , KnownSymbol ty
1067+ , Has sch schemas schema )
1068+ => QualifiedAlias sch ty
1069+ -- ^ name of the user defined composite type
1070+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
1071+createTypeCompositeFrom ty = createTypeComposite ty
1072+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
1073+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
1074+
1075+{-|
1076+`createDomain` creates a new domain. A domain is essentially a data type
1077+with constraints (restrictions on the allowed set of values).
1078+
1079+Domains are useful for abstracting common constraints on fields
1080+into a single location for maintenance. For example, several tables might
1081+contain email address columns, all requiring the same `check` constraint
1082+to verify the address syntax. Define a domain rather than setting up
1083+each table's constraint individually.
1084+
1085+>>> :{
1086+let
1087+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1088+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1089+in printSQL createPositive
1090+:}
1091+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1092+-}
1093+createDomain
1094+ :: (Has sch schemas schema, KnownSymbol dom)
1095+ => QualifiedAlias sch dom
1096+ -> (forall null. TypeExpression schemas (null ty))
1097+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1098+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
1099+createDomain dom ty condition =
1100+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1101+ <+> "AS" <+> renderTypeExpression ty
1102+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1103+
1104+{- |
1105+>>> :{
1106+let
1107+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
1108+ createSmallIntRange = createTypeRange #int2range int2
1109+in printSQL createSmallIntRange
1110+:}
1111+CREATE TYPE "int2range" AS RANGE (subtype = int2);
1112+-}
1113+createTypeRange
1114+ :: (Has sch schemas schema, KnownSymbol range)
1115+ => QualifiedAlias sch range
1116+ -> (forall null. TypeExpression schemas (null ty))
1117+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
1118+createTypeRange range ty = UnsafeDefinition $
1119+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
1120+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
1121+
1122+{- |
1123+>>> :{
1124+type Table = '[] :=>
1125+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
1126+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
1127+:}
1128+
1129+>>> :{
1130+let
1131+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
1132+ setup =
1133+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
1134+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
1135+in printSQL setup
1136+:}
1137+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
1138+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
1139+-}
1140+createIndex
1141+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
1142+ => Alias ix
1143+ -> QualifiedAlias sch tab
1144+ -> IndexMethod method
1145+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
1146+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
1147+createIndex ix tab method cols = UnsafeDefinition $
1148+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
1149+ <+> "USING" <+> renderSQL method
1150+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
1151+ <> ";"
1152+ where
1153+ renderIndex = \case
1154+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
1155+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
1156+ AscNullsFirst expression -> parenthesized (renderSQL expression)
1157+ <+> "ASC NULLS FIRST"
1158+ DescNullsFirst expression -> parenthesized (renderSQL expression)
1159+ <+> "DESC NULLS FIRST"
1160+ AscNullsLast expression -> parenthesized (renderSQL expression)
1161+ <+> "ASC NULLS LAST"
1162+ DescNullsLast expression -> parenthesized (renderSQL expression)
1163+ <+> "DESC NULLS LAST"
1164+
1165+createIndexIfNotExists
1166+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
1167+ => Alias ix
1168+ -> QualifiedAlias sch tab
1169+ -> IndexMethod method
1170+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
1171+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
1172+createIndexIfNotExists ix tab method cols = UnsafeDefinition $
1173+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
1174+ <+> "USING" <+> renderSQL method
1175+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
1176+ <> ";"
1177+ where
1178+ renderIndex = \case
1179+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
1180+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
1181+ AscNullsFirst expression -> parenthesized (renderSQL expression)
1182+ <+> "ASC NULLS FIRST"
1183+ DescNullsFirst expression -> parenthesized (renderSQL expression)
1184+ <+> "DESC NULLS FIRST"
1185+ AscNullsLast expression -> parenthesized (renderSQL expression)
1186+ <+> "ASC NULLS LAST"
1187+ DescNullsLast expression -> parenthesized (renderSQL expression)
1188+ <+> "DESC NULLS LAST"
1189+
1190+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
1191+ deriving stock (Eq, Ord, Show, GHC.Generic)
1192+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
1193+btree :: IndexMethod 'Btree
1194+btree = UnsafeIndexMethod "btree"
1195+hash :: IndexMethod 'Hash
1196+hash = UnsafeIndexMethod "hash"
1197+gist :: IndexMethod 'Gist
1198+gist = UnsafeIndexMethod "gist"
1199+spgist :: IndexMethod 'Spgist
1200+spgist = UnsafeIndexMethod "spgist"
1201+gin :: IndexMethod 'Gin
1202+gin = UnsafeIndexMethod "gin"
1203+brin :: IndexMethod 'Brin
1204+brin = UnsafeIndexMethod "brin"
1205+
1206+createFunction
1207+ :: ( Has sch schemas schema
1208+ , KnownSymbol fun
1209+ , SOP.SListI args )
1210+ => QualifiedAlias sch fun
1211+ -> NP (TypeExpression schemas) args
1212+ -> TypeExpression schemas ret
1213+ -> FunctionDefinition schemas args ('Returns ret)
1214+ -> Definition schemas (Alter sch (Create fun ('Function (args '::--> 'Returns ret)) schema) schemas)
1215+createFunction fun args ret fundef = UnsafeDefinition $
1216+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
1217+ <+> parenthesized (renderCommaSeparated renderSQL args)
1218+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
1219+
1220+createOrReplaceFunction
1221+ :: ( Has sch schemas schema
1222+ , KnownSymbol fun
1223+ , SOP.SListI args )
1224+ => QualifiedAlias sch fun
1225+ -> NP (TypeExpression schemas) args
1226+ -> TypeExpression schemas ret
1227+ -> FunctionDefinition schemas args ('Returns ret)
1228+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args '::--> 'Returns ret)) schema) schemas)
1229+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
1230+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
1231+ <+> parenthesized (renderCommaSeparated renderSQL args)
1232+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
1233+
1234+languageSqlExpr
1235+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret
1236+ -> FunctionDefinition schemas args ('Returns ret)
1237+languageSqlExpr expr = UnsafeFunctionDefinition $
1238+ "language sql as"
1239+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
1240+
1241+languageSqlQuery
1242+ :: Query '[] '[] schemas args rets
1243+ -> FunctionDefinition schemas args ('ReturnsTable rets)
1244+languageSqlQuery qry = UnsafeFunctionDefinition $
1245+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
1246+
1247+createSetFunction
1248+ :: ( Has sch schemas schema
1249+ , KnownSymbol fun
1250+ , SOP.SListI args
1251+ , SOP.SListI rets )
1252+ => QualifiedAlias sch fun
1253+ -> NP (TypeExpression schemas) args
1254+ -> NP (Aliased (TypeExpression schemas)) rets
1255+ -> FunctionDefinition schemas args ('ReturnsTable rets)
1256+ -> Definition schemas (Alter sch (Create fun ('Function (args '::--> 'ReturnsTable rets)) schema) schemas)
1257+createSetFunction fun args rets fundef = UnsafeDefinition $
1258+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
1259+ <+> parenthesized (renderCommaSeparated renderSQL args)
1260+ <+> "RETURNS" <+> "TABLE"
1261+ <+> parenthesized (renderCommaSeparated renderRet rets)
1262+ <+> renderSQL fundef <> ";"
1263+ where
1264+ renderRet :: Aliased (TypeExpression s) r -> ByteString
1265+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
1266+
1267+createOrReplaceSetFunction
1268+ :: ( Has sch schemas schema
1269+ , Has fun schema ('Function (args0 '::--> ret0))
1270+ , SOP.SListI args
1271+ , SOP.SListI rets )
1272+ => QualifiedAlias sch fun
1273+ -> NP (TypeExpression schemas) args
1274+ -> NP (Aliased (TypeExpression schemas)) rets
1275+ -> FunctionDefinition schemas args ('ReturnsTable rets)
1276+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args '::--> 'ReturnsTable rets)) schema) schemas)
1277+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
1278+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
1279+ <+> parenthesized (renderCommaSeparated renderSQL args)
1280+ <+> "RETURNS" <+> "TABLE"
1281+ <+> parenthesized (renderCommaSeparated renderRet rets)
1282+ <+> renderSQL fundef <> ";"
1283+ where
1284+ renderRet :: Aliased (TypeExpression s) r -> ByteString
1285+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
1286+
1287+createBinaryOp
1288+ :: forall op fun sch schemas schema x y z.
1289+ ( Has sch schemas schema
1290+ , Has fun schema ('Function ('[x,y] '::--> 'Returns z))
1291+ , KnownSymbol op )
1292+ => Alias fun
1293+ -> TypeExpression schemas x
1294+ -> TypeExpression schemas y
1295+ -> Definition schemas
1296+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
1297+createBinaryOp fun x y = UnsafeDefinition $
1298+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
1299+ <+> parenthesized (commaSeparated opdef)
1300+ where
1301+ opdef =
1302+ [ "FUNCTION" <+> "=" <+> renderSQL fun
1303+ , "LEFTARG" <+> "=" <+> renderSQL x
1304+ , "RIGHTARG" <+> "=" <+> renderSQL y ]
1305+
1306+createLeftOp
1307+ :: forall op fun sch schemas schema x y.
1308+ ( Has sch schemas schema
1309+ , Has fun schema ('Function ('[x] '::--> 'Returns y))
1310+ , KnownSymbol op )
1311+ => Alias fun
1312+ -> TypeExpression schemas x
1313+ -> Definition schemas
1314+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
1315+createLeftOp fun x = UnsafeDefinition $
1316+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
1317+ <+> parenthesized (commaSeparated opdef)
1318+ where
1319+ opdef =
1320+ [ "FUNCTION" <+> "=" <+> renderSQL fun
1321+ , "RIGHTARG" <+> "=" <+> renderSQL x ]
1322+
1323+createRightOp
1324+ :: forall op fun sch schemas schema x y.
1325+ ( Has sch schemas schema
1326+ , Has fun schema ('Function ('[x] '::--> 'Returns y))
1327+ , KnownSymbol op )
1328+ => Alias fun
1329+ -> TypeExpression schemas x
1330+ -> Definition schemas
1331+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
1332+createRightOp fun x = UnsafeDefinition $
1333+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
1334+ <+> parenthesized (commaSeparated opdef)
1335+ where
1336+ opdef =
1337+ [ "FUNCTION" <+> "=" <+> renderSQL fun
1338+ , "LEFTARG" <+> "=" <+> renderSQL x ]
1339+
1340+dropFunction
1341+ :: (Has sch schemas schema, Has fun schema ('Function (args '::--> ret)))
1342+ => QualifiedAlias sch fun
1343+ -- ^ name of the user defined function
1344+ -> Definition schemas (Alter sch (Drop fun schema) schemas)
1345+dropFunction fun = UnsafeDefinition $
1346+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
1347+
1348+dropOperator
1349+ :: (Has sch schemas schema, Has op schema ('Operator oper))
1350+ => QualifiedAlias sch op
1351+ -- ^ name of the user defined operator
1352+ -> Definition schemas (Alter sch (Drop op schema) schemas)
1353+dropOperator op = UnsafeDefinition $
1354+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
1355+
1356+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
1357+ { renderFunctionDefinition :: ByteString }
1358+ deriving (Eq,Show,GHC.Generic,NFData)
1359+instance RenderSQL (FunctionDefinition schemas args ret) where
1360+ renderSQL = renderFunctionDefinition
1361+
1362+-- |
1363+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
1364+-- DROP INDEX "ix";
1365+dropIndex
1366+ :: (Has sch schemas schema, KnownSymbol ix)
1367+ => QualifiedAlias sch ix
1368+ -- ^ name of the user defined index
1369+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
1370+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
1371+
1372+dropIndexIfExists
1373+ :: (Has sch schemas schema, KnownSymbol ix)
1374+ => QualifiedAlias sch ix
1375+ -- ^ name of the user defined index
1376+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
1377+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
1378+
1379+-- | Lift `PGTyped` to a field
1380+class FieldTyped schemas ty where
1381+ fieldtype :: Aliased (TypeExpression schemas) ty
1382+instance (KnownSymbol alias, PGTyped schemas ty)
1383+ => FieldTyped schemas (alias ::: ty) where
1384+ fieldtype = pgtype `As` Alias
1385+
1386+-- | Drop a type.
1387+--
1388+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1389+-- >>> instance SOP.Generic Schwarma
1390+-- >>> instance SOP.HasDatatypeInfo Schwarma
1391+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1392+-- DROP TYPE "schwarma";
1393+dropType
1394+ :: (Has sch schemas schema, KnownSymbol td)
1395+ => QualifiedAlias sch td
1396+ -- ^ name of the user defined type
1397+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
1398+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1399+
1400+dropTypeIfExists
1401+ :: (Has sch schemas schema, KnownSymbol td)
1402+ => QualifiedAlias sch td
1403+ -- ^ name of the user defined type
1404+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
1405+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1406+
1407+-- | `ColumnTypeExpression`s are used in `createTable` commands.
1408+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1409+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1410+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1411+instance RenderSQL (ColumnTypeExpression schemas ty) where
1412+ renderSQL = renderColumnTypeExpression
1413+
1414+-- | used in `createTable` commands as a column constraint to note that
1415+-- @NULL@ may be present in a column
1416+nullable
1417+ :: TypeExpression schemas (nullity ty)
1418+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1419+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1420+
1421+-- | used in `createTable` commands as a column constraint to ensure
1422+-- @NULL@ is not present in a column
1423+notNullable
1424+ :: TypeExpression schemas (nullity ty)
1425+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1426+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1427+
1428+-- | used in `createTable` commands as a column constraint to give a default
1429+default_
1430+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1431+ -> ColumnTypeExpression schemas ('NoDef :=> ty)
1432+ -> ColumnTypeExpression schemas ('Def :=> ty)
1433+default_ x ty = UnsafeColumnTypeExpression $
1434+ renderSQL ty <+> "DEFAULT" <+> renderExpression x
1435+
1436+-- | not a true type, but merely a notational convenience for creating
1437+-- unique identifier columns with type `PGint2`
1438+serial2, smallserial
1439+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1440+serial2 = UnsafeColumnTypeExpression "serial2"
1441+smallserial = UnsafeColumnTypeExpression "smallserial"
1442+-- | not a true type, but merely a notational convenience for creating
1443+-- unique identifier columns with type `PGint4`
1444+serial4, serial
1445+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1446+serial4 = UnsafeColumnTypeExpression "serial4"
1447+serial = UnsafeColumnTypeExpression "serial"
1448+-- | not a true type, but merely a notational convenience for creating
1449+-- unique identifier columns with type `PGint8`
1450+serial8, bigserial
1451+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1452+serial8 = UnsafeColumnTypeExpression "serial8"
1453+bigserial = UnsafeColumnTypeExpression "bigserial"