mirror of
https://github.com/ilyakooo0/squeal.git
synced 2024-09-11 05:45:47 +03:00
more rehierarching
This commit is contained in:
Eitan Chatav
parent
e3cc5561d7
commit
c42b09d1f3
@ -28,6 +28,8 @@ library
|
||||
Squeal.PostgreSQL.Definition.Function
|
||||
Squeal.PostgreSQL.Definition.Index
|
||||
Squeal.PostgreSQL.Definition.Table
|
||||
Squeal.PostgreSQL.Definition.Table.Column
|
||||
Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
Squeal.PostgreSQL.Definition.Type
|
||||
Squeal.PostgreSQL.Definition.Schema
|
||||
Squeal.PostgreSQL.Definition.View
|
||||
|
||||
@ -199,6 +199,8 @@ import Squeal.PostgreSQL.Definition.Function as X
|
||||
import Squeal.PostgreSQL.Definition.Index as X
|
||||
import Squeal.PostgreSQL.Definition.Schema as X
|
||||
import Squeal.PostgreSQL.Definition.Table as X
|
||||
import Squeal.PostgreSQL.Definition.Table.Column as X
|
||||
import Squeal.PostgreSQL.Definition.Table.Constraint as X
|
||||
import Squeal.PostgreSQL.Definition.Type as X
|
||||
import Squeal.PostgreSQL.Definition.View as X
|
||||
import Squeal.PostgreSQL.Expression as X
|
||||
|
||||
@ -54,7 +54,7 @@ import qualified Generics.SOP as SOP
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition (Definition (..))
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.List
|
||||
|
||||
@ -49,7 +49,7 @@ import GHC.TypeLits
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition (Definition (..))
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Expression.Sort
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
@ -39,7 +39,7 @@ module Squeal.PostgreSQL.Definition.Schema
|
||||
import GHC.TypeLits
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition (Definition (..))
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
|
||||
@ -34,14 +34,6 @@ module Squeal.PostgreSQL.Definition.Table
|
||||
, createTableIfNotExists
|
||||
, dropTable
|
||||
, dropTableIfExists
|
||||
, TableConstraintExpression (..)
|
||||
, check
|
||||
, unique
|
||||
, primaryKey
|
||||
, foreignKey
|
||||
, ForeignKeyed
|
||||
, OnDeleteClause (..)
|
||||
, OnUpdateClause (..)
|
||||
, alterTable
|
||||
, alterTableRename
|
||||
, AlterTable (..)
|
||||
@ -57,17 +49,6 @@ module Squeal.PostgreSQL.Definition.Table
|
||||
, setNotNull
|
||||
, dropNotNull
|
||||
, alterType
|
||||
-- * Columns
|
||||
, ColumnTypeExpression (..)
|
||||
, nullable
|
||||
, notNullable
|
||||
, default_
|
||||
, serial2
|
||||
, smallserial
|
||||
, serial4
|
||||
, serial
|
||||
, serial8
|
||||
, bigserial
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
@ -78,10 +59,10 @@ import qualified Generics.SOP as SOP
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition (Definition (..))
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Definition.Table.Column
|
||||
import Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.Logic
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
@ -195,288 +176,6 @@ renderCreation tab columns constraints = renderSQL tab
|
||||
renderConstraint (constraint `As` alias) =
|
||||
"CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
|
||||
|
||||
-- | Data types are a way to limit the kind of data that can be stored in a
|
||||
-- table. For many applications, however, the constraint they provide is
|
||||
-- too coarse. For example, a column containing a product price should
|
||||
-- probably only accept positive values. But there is no standard data type
|
||||
-- that accepts only positive numbers. Another issue is that you might want
|
||||
-- to constrain column data with respect to other columns or rows.
|
||||
-- For example, in a table containing product information,
|
||||
-- there should be only one row for each product number.
|
||||
-- `TableConstraint`s give you as much control over the data in your tables
|
||||
-- as you wish. If a user attempts to store data in a column that would
|
||||
-- violate a constraint, an error is raised. This applies
|
||||
-- even if the value came from the default value definition.
|
||||
newtype TableConstraintExpression
|
||||
(sch :: Symbol)
|
||||
(tab :: Symbol)
|
||||
(schemas :: SchemasType)
|
||||
(constraint :: TableConstraint)
|
||||
= UnsafeTableConstraintExpression
|
||||
{ renderTableConstraintExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
instance RenderSQL
|
||||
(TableConstraintExpression sch tab schemas constraint) where
|
||||
renderSQL = renderTableConstraintExpression
|
||||
|
||||
{-| A `check` constraint is the most generic `TableConstraint` type.
|
||||
It allows you to specify that the value in a certain column must satisfy
|
||||
a Boolean (truth-value) expression.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
|
||||
"a" ::: 'NoDef :=> 'NotNull 'PGint4,
|
||||
"b" ::: 'NoDef :=> 'NotNull 'PGint4
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( (int & notNullable) `as` #a :*
|
||||
(int & notNullable) `as` #b )
|
||||
( check (#a :* #b) (#a .> #b) `as` #inequality )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
|
||||
-}
|
||||
check
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table)
|
||||
, HasAll aliases (TableToRow table) subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify the subcolumns which are getting checked
|
||||
-> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
|
||||
-- ^ a closed `Condition` on those subcolumns
|
||||
-> TableConstraintExpression sch tab schemas ('Check aliases)
|
||||
check _cols condition = UnsafeTableConstraintExpression $
|
||||
"CHECK" <+> parenthesized (renderSQL condition)
|
||||
|
||||
{-| A `unique` constraint ensure that the data contained in a column,
|
||||
or a group of columns, is unique among all the rows in the table.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
|
||||
"a" ::: 'NoDef :=> 'Null 'PGint4,
|
||||
"b" ::: 'NoDef :=> 'Null 'PGint4
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( (int & nullable) `as` #a :*
|
||||
(int & nullable) `as` #b )
|
||||
( unique (#a :* #b) `as` #uq_a_b )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
|
||||
-}
|
||||
unique
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema('Table table)
|
||||
, HasAll aliases (TableToRow table) subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify subcolumns which together are unique for each row
|
||||
-> TableConstraintExpression sch tab schemas ('Unique aliases)
|
||||
unique columns = UnsafeTableConstraintExpression $
|
||||
"UNIQUE" <+> parenthesized (renderSQL columns)
|
||||
|
||||
{-| A `primaryKey` constraint indicates that a column, or group of columns,
|
||||
can be used as a unique identifier for rows in the table.
|
||||
This requires that the values be both unique and not null.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
|
||||
"id" ::: 'Def :=> 'NotNull 'PGint4,
|
||||
"name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name )
|
||||
( primaryKey #id `as` #pk_id )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
|
||||
-}
|
||||
primaryKey
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table)
|
||||
, HasAll aliases (TableToColumns table) subcolumns
|
||||
, AllNotNull subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify the subcolumns which together form a primary key.
|
||||
-> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
|
||||
primaryKey columns = UnsafeTableConstraintExpression $
|
||||
"PRIMARY KEY" <+> parenthesized (renderSQL columns)
|
||||
|
||||
{-| A `foreignKey` specifies that the values in a column
|
||||
(or a group of columns) must match the values appearing in some row of
|
||||
another table. We say this maintains the referential integrity
|
||||
between two related tables.
|
||||
|
||||
>>> :{
|
||||
type Schema =
|
||||
'[ "users" ::: 'Table (
|
||||
'[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
])
|
||||
, "emails" ::: 'Table (
|
||||
'[ "pk_emails" ::: 'PrimaryKey '["id"]
|
||||
, "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
|
||||
] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
|
||||
, "email" ::: 'NoDef :=> 'Null 'PGtext
|
||||
])
|
||||
]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public Schema)
|
||||
setup =
|
||||
createTable #users
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name )
|
||||
( primaryKey #id `as` #pk_users ) >>>
|
||||
createTable #emails
|
||||
( serial `as` #id :*
|
||||
(int & notNullable) `as` #user_id :*
|
||||
(text & nullable) `as` #email )
|
||||
( primaryKey #id `as` #pk_emails :*
|
||||
foreignKey #user_id #users #id
|
||||
OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
|
||||
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);
|
||||
|
||||
A `foreignKey` can even be a table self-reference.
|
||||
|
||||
>>> :{
|
||||
type Schema =
|
||||
'[ "employees" ::: 'Table (
|
||||
'[ "employees_pk" ::: 'PrimaryKey '["id"]
|
||||
, "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
|
||||
] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
, "employer_id" ::: 'NoDef :=> 'Null 'PGint4
|
||||
])
|
||||
]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public Schema)
|
||||
setup =
|
||||
createTable #employees
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name :*
|
||||
(integer & nullable) `as` #employer_id )
|
||||
( primaryKey #id `as` #employees_pk :*
|
||||
foreignKey #employer_id #employees #id
|
||||
OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
|
||||
in printSQL setup
|
||||
:}
|
||||
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);
|
||||
-}
|
||||
foreignKey
|
||||
:: (ForeignKeyed schemas sch schema child parent
|
||||
table reftable
|
||||
columns refcolumns
|
||||
constraints cols
|
||||
reftys tys )
|
||||
=> NP Alias columns
|
||||
-- ^ column or columns in the table
|
||||
-> Alias parent
|
||||
-- ^ reference table
|
||||
-> NP Alias refcolumns
|
||||
-- ^ reference column or columns in the reference table
|
||||
-> OnDeleteClause
|
||||
-- ^ what to do when reference is deleted
|
||||
-> OnUpdateClause
|
||||
-- ^ what to do when reference is updated
|
||||
-> TableConstraintExpression sch child schemas
|
||||
('ForeignKey columns parent refcolumns)
|
||||
foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
|
||||
"FOREIGN KEY" <+> parenthesized (renderSQL keys)
|
||||
<+> "REFERENCES" <+> renderSQL parent
|
||||
<+> parenthesized (renderSQL refs)
|
||||
<+> renderSQL ondel
|
||||
<+> renderSQL onupd
|
||||
|
||||
-- | A constraint synonym between types involved in a foreign key constraint.
|
||||
type ForeignKeyed schemas
|
||||
sch
|
||||
schema
|
||||
child parent
|
||||
table reftable
|
||||
columns refcolumns
|
||||
constraints cols
|
||||
reftys tys =
|
||||
( Has sch schemas schema
|
||||
, Has child schema ('Table table)
|
||||
, Has parent schema ('Table reftable)
|
||||
, HasAll columns (TableToColumns table) tys
|
||||
, reftable ~ (constraints :=> cols)
|
||||
, HasAll refcolumns cols reftys
|
||||
, SOP.AllZip SamePGType tys reftys
|
||||
, Uniquely refcolumns constraints )
|
||||
|
||||
-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
|
||||
data OnDeleteClause
|
||||
= OnDeleteNoAction
|
||||
-- ^ if any referencing rows still exist when the constraint is checked,
|
||||
-- an error is raised
|
||||
| OnDeleteRestrict -- ^ prevents deletion of a referenced row
|
||||
| OnDeleteCascade
|
||||
-- ^ specifies that when a referenced row is deleted,
|
||||
-- row(s) referencing it should be automatically deleted as well
|
||||
deriving (GHC.Generic,Show,Eq,Ord)
|
||||
instance NFData OnDeleteClause
|
||||
-- | Render `OnDeleteClause`.
|
||||
instance RenderSQL OnDeleteClause where
|
||||
renderSQL = \case
|
||||
OnDeleteNoAction -> "ON DELETE NO ACTION"
|
||||
OnDeleteRestrict -> "ON DELETE RESTRICT"
|
||||
OnDeleteCascade -> "ON DELETE CASCADE"
|
||||
|
||||
-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
|
||||
-- when a referenced column is changed (updated).
|
||||
data OnUpdateClause
|
||||
= OnUpdateNoAction
|
||||
-- ^ if any referencing rows has not changed when the constraint is checked,
|
||||
-- an error is raised
|
||||
| OnUpdateRestrict -- ^ prevents update of a referenced row
|
||||
| OnUpdateCascade
|
||||
-- ^ the updated values of the referenced column(s) should be copied
|
||||
-- into the referencing row(s)
|
||||
deriving (GHC.Generic,Show,Eq,Ord)
|
||||
instance NFData OnUpdateClause
|
||||
|
||||
-- | Render `OnUpdateClause`.
|
||||
instance RenderSQL OnUpdateClause where
|
||||
renderSQL = \case
|
||||
OnUpdateNoAction -> "ON UPDATE NO ACTION"
|
||||
OnUpdateRestrict -> "ON UPDATE RESTRICT"
|
||||
OnUpdateCascade -> "ON UPDATE CASCADE"
|
||||
|
||||
-- | `dropTable` removes a table from the schema.
|
||||
--
|
||||
-- >>> :{
|
||||
@ -776,51 +475,3 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
|
||||
-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
|
||||
alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
|
||||
alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
|
||||
|
||||
-- | `ColumnTypeExpression`s are used in `createTable` commands.
|
||||
newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
|
||||
= UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
instance RenderSQL (ColumnTypeExpression schemas ty) where
|
||||
renderSQL = renderColumnTypeExpression
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to note that
|
||||
-- @NULL@ may be present in a column
|
||||
nullable
|
||||
:: TypeExpression schemas (nullity ty)
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
|
||||
nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to ensure
|
||||
-- @NULL@ is not present in a column
|
||||
notNullable
|
||||
:: TypeExpression schemas (nullity ty)
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
|
||||
notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to give a default
|
||||
default_
|
||||
:: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> ty)
|
||||
-> ColumnTypeExpression schemas ('Def :=> ty)
|
||||
default_ x ty = UnsafeColumnTypeExpression $
|
||||
renderSQL ty <+> "DEFAULT" <+> renderExpression x
|
||||
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint2`
|
||||
serial2, smallserial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
|
||||
serial2 = UnsafeColumnTypeExpression "serial2"
|
||||
smallserial = UnsafeColumnTypeExpression "smallserial"
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint4`
|
||||
serial4, serial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
|
||||
serial4 = UnsafeColumnTypeExpression "serial4"
|
||||
serial = UnsafeColumnTypeExpression "serial"
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint8`
|
||||
serial8, bigserial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
|
||||
serial8 = UnsafeColumnTypeExpression "serial8"
|
||||
bigserial = UnsafeColumnTypeExpression "bigserial"
|
||||
|
||||
@ -0,0 +1,105 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Table.Column
|
||||
Description: Column type expressions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Column type expressions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Table.Column
|
||||
( ColumnTypeExpression (..)
|
||||
, nullable
|
||||
, notNullable
|
||||
, default_
|
||||
, serial2
|
||||
, smallserial
|
||||
, serial4
|
||||
, serial
|
||||
, serial8
|
||||
, bigserial
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.ByteString
|
||||
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
-- | `ColumnTypeExpression`s are used in `createTable` commands.
|
||||
newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
|
||||
= UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
instance RenderSQL (ColumnTypeExpression schemas ty) where
|
||||
renderSQL = renderColumnTypeExpression
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to note that
|
||||
-- @NULL@ may be present in a column
|
||||
nullable
|
||||
:: TypeExpression schemas (nullity ty)
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
|
||||
nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to ensure
|
||||
-- @NULL@ is not present in a column
|
||||
notNullable
|
||||
:: TypeExpression schemas (nullity ty)
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
|
||||
notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to give a default
|
||||
default_
|
||||
:: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> ty)
|
||||
-> ColumnTypeExpression schemas ('Def :=> ty)
|
||||
default_ x ty = UnsafeColumnTypeExpression $
|
||||
renderSQL ty <+> "DEFAULT" <+> renderExpression x
|
||||
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint2`
|
||||
serial2, smallserial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
|
||||
serial2 = UnsafeColumnTypeExpression "serial2"
|
||||
smallserial = UnsafeColumnTypeExpression "smallserial"
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint4`
|
||||
serial4, serial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
|
||||
serial4 = UnsafeColumnTypeExpression "serial4"
|
||||
serial = UnsafeColumnTypeExpression "serial"
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint8`
|
||||
serial8, bigserial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
|
||||
serial8 = UnsafeColumnTypeExpression "serial8"
|
||||
bigserial = UnsafeColumnTypeExpression "bigserial"
|
||||
@ -0,0 +1,339 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
Description: Table constraint expressions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Table constraint expressions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
( TableConstraintExpression (..)
|
||||
, check
|
||||
, unique
|
||||
, primaryKey
|
||||
, foreignKey
|
||||
, ForeignKeyed
|
||||
, OnDeleteClause (..)
|
||||
, OnUpdateClause (..)
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.ByteString
|
||||
import GHC.TypeLits
|
||||
|
||||
import qualified Generics.SOP as SOP
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression.Logic
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
-- | Data types are a way to limit the kind of data that can be stored in a
|
||||
-- table. For many applications, however, the constraint they provide is
|
||||
-- too coarse. For example, a column containing a product price should
|
||||
-- probably only accept positive values. But there is no standard data type
|
||||
-- that accepts only positive numbers. Another issue is that you might want
|
||||
-- to constrain column data with respect to other columns or rows.
|
||||
-- For example, in a table containing product information,
|
||||
-- there should be only one row for each product number.
|
||||
-- `TableConstraint`s give you as much control over the data in your tables
|
||||
-- as you wish. If a user attempts to store data in a column that would
|
||||
-- violate a constraint, an error is raised. This applies
|
||||
-- even if the value came from the default value definition.
|
||||
newtype TableConstraintExpression
|
||||
(sch :: Symbol)
|
||||
(tab :: Symbol)
|
||||
(schemas :: SchemasType)
|
||||
(constraint :: TableConstraint)
|
||||
= UnsafeTableConstraintExpression
|
||||
{ renderTableConstraintExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
instance RenderSQL
|
||||
(TableConstraintExpression sch tab schemas constraint) where
|
||||
renderSQL = renderTableConstraintExpression
|
||||
|
||||
{-| A `check` constraint is the most generic `TableConstraint` type.
|
||||
It allows you to specify that the value in a certain column must satisfy
|
||||
a Boolean (truth-value) expression.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
|
||||
"a" ::: 'NoDef :=> 'NotNull 'PGint4,
|
||||
"b" ::: 'NoDef :=> 'NotNull 'PGint4
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( (int & notNullable) `as` #a :*
|
||||
(int & notNullable) `as` #b )
|
||||
( check (#a :* #b) (#a .> #b) `as` #inequality )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
|
||||
-}
|
||||
check
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table)
|
||||
, HasAll aliases (TableToRow table) subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify the subcolumns which are getting checked
|
||||
-> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
|
||||
-- ^ a closed `Condition` on those subcolumns
|
||||
-> TableConstraintExpression sch tab schemas ('Check aliases)
|
||||
check _cols condition = UnsafeTableConstraintExpression $
|
||||
"CHECK" <+> parenthesized (renderSQL condition)
|
||||
|
||||
{-| A `unique` constraint ensure that the data contained in a column,
|
||||
or a group of columns, is unique among all the rows in the table.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
|
||||
"a" ::: 'NoDef :=> 'Null 'PGint4,
|
||||
"b" ::: 'NoDef :=> 'Null 'PGint4
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( (int & nullable) `as` #a :*
|
||||
(int & nullable) `as` #b )
|
||||
( unique (#a :* #b) `as` #uq_a_b )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
|
||||
-}
|
||||
unique
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema('Table table)
|
||||
, HasAll aliases (TableToRow table) subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify subcolumns which together are unique for each row
|
||||
-> TableConstraintExpression sch tab schemas ('Unique aliases)
|
||||
unique columns = UnsafeTableConstraintExpression $
|
||||
"UNIQUE" <+> parenthesized (renderSQL columns)
|
||||
|
||||
{-| A `primaryKey` constraint indicates that a column, or group of columns,
|
||||
can be used as a unique identifier for rows in the table.
|
||||
This requires that the values be both unique and not null.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
|
||||
"id" ::: 'Def :=> 'NotNull 'PGint4,
|
||||
"name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name )
|
||||
( primaryKey #id `as` #pk_id )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
|
||||
-}
|
||||
primaryKey
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table)
|
||||
, HasAll aliases (TableToColumns table) subcolumns
|
||||
, AllNotNull subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify the subcolumns which together form a primary key.
|
||||
-> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
|
||||
primaryKey columns = UnsafeTableConstraintExpression $
|
||||
"PRIMARY KEY" <+> parenthesized (renderSQL columns)
|
||||
|
||||
{-| A `foreignKey` specifies that the values in a column
|
||||
(or a group of columns) must match the values appearing in some row of
|
||||
another table. We say this maintains the referential integrity
|
||||
between two related tables.
|
||||
|
||||
>>> :{
|
||||
type Schema =
|
||||
'[ "users" ::: 'Table (
|
||||
'[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
])
|
||||
, "emails" ::: 'Table (
|
||||
'[ "pk_emails" ::: 'PrimaryKey '["id"]
|
||||
, "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
|
||||
] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
|
||||
, "email" ::: 'NoDef :=> 'Null 'PGtext
|
||||
])
|
||||
]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public Schema)
|
||||
setup =
|
||||
createTable #users
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name )
|
||||
( primaryKey #id `as` #pk_users ) >>>
|
||||
createTable #emails
|
||||
( serial `as` #id :*
|
||||
(int & notNullable) `as` #user_id :*
|
||||
(text & nullable) `as` #email )
|
||||
( primaryKey #id `as` #pk_emails :*
|
||||
foreignKey #user_id #users #id
|
||||
OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
|
||||
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);
|
||||
|
||||
A `foreignKey` can even be a table self-reference.
|
||||
|
||||
>>> :{
|
||||
type Schema =
|
||||
'[ "employees" ::: 'Table (
|
||||
'[ "employees_pk" ::: 'PrimaryKey '["id"]
|
||||
, "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
|
||||
] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
, "employer_id" ::: 'NoDef :=> 'Null 'PGint4
|
||||
])
|
||||
]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public Schema)
|
||||
setup =
|
||||
createTable #employees
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name :*
|
||||
(integer & nullable) `as` #employer_id )
|
||||
( primaryKey #id `as` #employees_pk :*
|
||||
foreignKey #employer_id #employees #id
|
||||
OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
|
||||
in printSQL setup
|
||||
:}
|
||||
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);
|
||||
-}
|
||||
foreignKey
|
||||
:: (ForeignKeyed schemas sch schema child parent
|
||||
table reftable
|
||||
columns refcolumns
|
||||
constraints cols
|
||||
reftys tys )
|
||||
=> NP Alias columns
|
||||
-- ^ column or columns in the table
|
||||
-> Alias parent
|
||||
-- ^ reference table
|
||||
-> NP Alias refcolumns
|
||||
-- ^ reference column or columns in the reference table
|
||||
-> OnDeleteClause
|
||||
-- ^ what to do when reference is deleted
|
||||
-> OnUpdateClause
|
||||
-- ^ what to do when reference is updated
|
||||
-> TableConstraintExpression sch child schemas
|
||||
('ForeignKey columns parent refcolumns)
|
||||
foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
|
||||
"FOREIGN KEY" <+> parenthesized (renderSQL keys)
|
||||
<+> "REFERENCES" <+> renderSQL parent
|
||||
<+> parenthesized (renderSQL refs)
|
||||
<+> renderSQL ondel
|
||||
<+> renderSQL onupd
|
||||
|
||||
-- | A constraint synonym between types involved in a foreign key constraint.
|
||||
type ForeignKeyed schemas
|
||||
sch
|
||||
schema
|
||||
child parent
|
||||
table reftable
|
||||
columns refcolumns
|
||||
constraints cols
|
||||
reftys tys =
|
||||
( Has sch schemas schema
|
||||
, Has child schema ('Table table)
|
||||
, Has parent schema ('Table reftable)
|
||||
, HasAll columns (TableToColumns table) tys
|
||||
, reftable ~ (constraints :=> cols)
|
||||
, HasAll refcolumns cols reftys
|
||||
, SOP.AllZip SamePGType tys reftys
|
||||
, Uniquely refcolumns constraints )
|
||||
|
||||
-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
|
||||
data OnDeleteClause
|
||||
= OnDeleteNoAction
|
||||
-- ^ if any referencing rows still exist when the constraint is checked,
|
||||
-- an error is raised
|
||||
| OnDeleteRestrict -- ^ prevents deletion of a referenced row
|
||||
| OnDeleteCascade
|
||||
-- ^ specifies that when a referenced row is deleted,
|
||||
-- row(s) referencing it should be automatically deleted as well
|
||||
deriving (GHC.Generic,Show,Eq,Ord)
|
||||
instance NFData OnDeleteClause
|
||||
-- | Render `OnDeleteClause`.
|
||||
instance RenderSQL OnDeleteClause where
|
||||
renderSQL = \case
|
||||
OnDeleteNoAction -> "ON DELETE NO ACTION"
|
||||
OnDeleteRestrict -> "ON DELETE RESTRICT"
|
||||
OnDeleteCascade -> "ON DELETE CASCADE"
|
||||
|
||||
-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
|
||||
-- when a referenced column is changed (updated).
|
||||
data OnUpdateClause
|
||||
= OnUpdateNoAction
|
||||
-- ^ if any referencing rows has not changed when the constraint is checked,
|
||||
-- an error is raised
|
||||
| OnUpdateRestrict -- ^ prevents update of a referenced row
|
||||
| OnUpdateCascade
|
||||
-- ^ the updated values of the referenced column(s) should be copied
|
||||
-- into the referencing row(s)
|
||||
deriving (GHC.Generic,Show,Eq,Ord)
|
||||
instance NFData OnUpdateClause
|
||||
|
||||
-- | Render `OnUpdateClause`.
|
||||
instance RenderSQL OnUpdateClause where
|
||||
renderSQL = \case
|
||||
OnUpdateNoAction -> "ON UPDATE NO ACTION"
|
||||
OnUpdateRestrict -> "ON UPDATE RESTRICT"
|
||||
OnUpdateCascade -> "ON UPDATE CASCADE"
|
||||
@ -50,7 +50,7 @@ import qualified Generics.SOP as SOP
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression.Logic
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.Definition (Definition (..))
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.PG
|
||||
import Squeal.PostgreSQL.Render
|
||||
|
||||
@ -39,7 +39,7 @@ module Squeal.PostgreSQL.Definition.View
|
||||
import GHC.TypeLits
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition (Definition (..))
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Query
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
@ -168,6 +168,8 @@ import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Binary
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Definition.Table
|
||||
import Squeal.PostgreSQL.Definition.Table.Column
|
||||
import Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
import Squeal.PostgreSQL.Expression.Comparison
|
||||
import Squeal.PostgreSQL.Expression.Parameter
|
||||
import Squeal.PostgreSQL.Expression.Time
|
||||
|
||||
Loading…
Reference in New Issue
Block a user