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