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