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