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