git.iko.soy/squeal
on dev help sign in
Merge pull request #17 from morphismtech/pgconstraint4

Pgconstraint4

commitc80f5d8b59277fef94ad9b3b54e602547caf4922 authorEitan Chatav <eitan.chatav@gmail.com> dateFri 8 Dec 2017, 14:06 (9 years ago) parent56e20e9c9d81df
7 files changed+193−129
compare with dev
unifiedsplit
squeal-postgresql/exe/Example.hs+17−17 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+79−67 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+14−5 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+9−5 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+4−4 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+5−5 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+65−26
squeal-postgresql/exe/Example.hs+17−17
@@ -4,6 +4,7 @@
44 , FlexibleContexts
55 , OverloadedLabels
66 , OverloadedStrings
7+ , PolyKinds
78 , TypeApplications
89 , TypeOperators
910#-}
@@ -23,14 +24,15 @@ import qualified Generics.SOP as SOP
2324import qualified GHC.Generics as GHC
2425
2526type Schema =
26− '[ "users" :::
27− '[ "id" ::: ('[ 'Default, 'Unique] :=> 'NotNull 'PGint4)
28− , "name" ::: ('[] :=> 'NotNull 'PGtext)
27+ '[ "users" ::: '[] :=>
28+ '[ "id" ::: AsSet '[ 'Default, 'Unique] :=> 'NotNull 'PGint4
29+ , "name" ::: '[] :=> 'NotNull 'PGtext
2930 ]
30− , "emails" :::
31− '[ "id" ::: ('[ 'Default, 'Unique] :=> 'NotNull 'PGint4)
32− , "user_id" ::: ('[] :=> 'NotNull 'PGint4)
33− , "email" ::: ('[] :=> 'Null 'PGtext)
31+ , "emails" ::: AsSet
32+ '[ 'ForeignKey '["user_id"] "users" '["id"] ] :=>
33+ '[ "id" ::: AsSet '[ 'Default, 'Unique] :=> 'NotNull 'PGint4
34+ , "user_id" ::: '[] :=> 'NotNull 'PGint4
35+ , "email" ::: '[] :=> 'Null 'PGtext
3436 ]
3537 ]
3638
@@ -38,29 +40,27 @@ setup :: Definition '[] Schema
3840setup =
3941 createTable #users
4042 ( serial `As` #id :*
41− (text & notNull) `As` #name :* Nil )
42− [ primaryKey (Column #id :* Nil) ]
43+ (text & notNull) `As` #name :* Nil ) Nil
4344 >>>
4445 createTable #emails
4546 ( serial `As` #id :*
4647 (int & notNull) `As` #user_id :*
4748 text `As` #email :* Nil )
48− [ primaryKey (Column #id :* Nil)
49− , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
50− OnDeleteCascade OnUpdateCascade ]
49+ ( foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
50+ OnDeleteCascade OnUpdateCascade :* Nil )
5151
5252teardown :: Definition Schema '[]
5353teardown = dropTable #emails >>> dropTable #users
5454
5555insertUser :: Manipulation Schema
56− '[ '[] ::=> 'NotNull 'PGtext]
57− '[ "fromOnly" ::: ('[] ::=> 'NotNull 'PGint4) ]
56+ '[ '[] :=> 'NotNull 'PGtext]
57+ '[ "fromOnly" ::: ('[] :=> 'NotNull 'PGint4) ]
5858insertUser = insertInto #users
5959 ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
6060 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
6161
6262insertEmail :: Manipulation Schema
63− '[ '[] ::=> 'NotNull 'PGint4, '[] ::=> 'Null 'PGtext] '[]
63+ '[ '[] :=> 'NotNull 'PGint4, '[] :=> 'Null 'PGtext] '[]
6464insertEmail = insertInto #emails ( Values
6565 ( def `As` #id :*
6666 param @1 `As` #user_id :*
@@ -68,8 +68,8 @@ insertEmail = insertInto #emails ( Values
6868 OnConflictDoNothing (Returning Nil)
6969
7070getUsers :: Query Schema '[]
71− '[ "userName" ::: ('[] ::=> 'NotNull 'PGtext)
72− , "userEmail" ::: ('[] ::=> 'Null 'PGtext) ]
71+ '[ "userName" ::: ('[] :=> 'NotNull 'PGtext)
72+ , "userEmail" ::: ('[] :=> 'Null 'PGtext) ]
7373getUsers = select
7474 (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
7575 ( from (Table (#users `As` #u)
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+79−67
@@ -12,6 +12,7 @@ Squeal data definition language.
1212 DataKinds
1313 , DeriveDataTypeable
1414 , DeriveGeneric
15+ , FlexibleContexts
1516 , GADTs
1617 , GeneralizedNewtypeDeriving
1718 , KindSignatures
@@ -29,7 +30,7 @@ module Squeal.PostgreSQL.Definition
2930 , (>>>)
3031 -- * Create
3132 , createTable
32− , TableConstraint (UnsafeTableConstraint, renderTableConstraint)
33+ , TableConstraintExpression (..)
3334 , check
3435 , unique
3536 , primaryKey
@@ -43,12 +44,12 @@ module Squeal.PostgreSQL.Definition
4344 -- * Alter
4445 , alterTable
4546 , alterTableRename
46− , alterTableAddConstraint
47− , AlterColumns (UnsafeAlterColumns, renderAlterColumns)
47+ , addConstraint
48+ , AlterTable (UnsafeAlterTable, renderAlterTable)
4849 , addColumnDefault
4950 , addColumnNull
5051 , dropColumn
51− , dropColumnCascade
52+ -- , dropColumnCascade
5253 , renameColumn
5354 , alterColumn
5455 , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
@@ -82,8 +83,8 @@ statements
8283-- database, like a `createTable`, `dropTable`, or `alterTable` command.
8384-- `Definition`s may be composed using the `>>>` operator.
8485newtype Definition
85− (schema0 :: TablesType)
86− (schema1 :: TablesType)
86+ (schema0 :: SchemaType)
87+ (schema1 :: SchemaType)
8788 = UnsafeDefinition { renderDefinition :: ByteString }
8889 deriving (GHC.Generic,Show,Eq,Ord,NFData)
8990
@@ -105,27 +106,26 @@ CREATE statements
105106-- :}
106107-- "CREATE TABLE tab (a int, b real);"
107108createTable
108− :: (KnownSymbol table, SOP.SListI columns)
109− => Alias table -- ^ the name of the table to add
109+ :: ( KnownSymbol tab
110+ , SOP.SListI columns
111+ , SOP.SListI constraints
112+ , table ~ (constraints :=> (column ': columns)))
113+ => Alias tab -- ^ the name of the table to add
110114 -> NP (Aliased TypeExpression) (column ': columns)
111115 -- ^ the names and datatype of each column
112− -> [TableConstraint schema (column ': columns)]
116+ -> NP (TableConstraintExpression schema (column ': columns)) constraints
113117 -- ^ constraints that must hold for the table
114− -> Definition schema (Create table (column ': columns) schema)
118+ -> Definition schema (Create tab table schema)
115119createTable table columns constraints = UnsafeDefinition $
116120 "CREATE TABLE" <+> renderAlias table
117121 <+> parenthesized
118122 ( renderCommaSeparated renderColumnDef columns
119− <> renderConstraints constraints )
123+ <> renderCommaSeparated renderTableConstraintExpression constraints )
120124 <> ";"
121125 where
122126 renderColumnDef :: Aliased TypeExpression x -> ByteString
123127 renderColumnDef (ty `As` column) =
124128 renderAlias column <+> renderTypeExpression ty
125− renderConstraints :: [TableConstraint schema columns] -> ByteString
126− renderConstraints = \case
127− [] -> ""
128− _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
129129
130130-- | Data types are a way to limit the kind of data that can be stored in a
131131-- table. For many applications, however, the constraint they provide is
@@ -139,10 +139,12 @@ createTable table columns constraints = UnsafeDefinition $
139139-- as you wish. If a user attempts to store data in a column that would
140140-- violate a constraint, an error is raised. This applies
141141-- even if the value came from the default value definition.
142−newtype TableConstraint
143− (schema :: TablesType)
142+newtype TableConstraintExpression
143+ (schema :: SchemaType)
144144 (columns :: ColumnsType)
145− = UnsafeTableConstraint { renderTableConstraint :: ByteString }
145+ (tableConstraint :: TableConstraint)
146+ = UnsafeTableConstraintExpression
147+ { renderTableConstraintExpression :: ByteString }
146148 deriving (GHC.Generic,Show,Eq,Ord,NFData)
147149
148150-- | A `check` constraint is the most generic `TableConstraint` type.
@@ -160,8 +162,8 @@ newtype TableConstraint
160162check
161163 :: Condition '[table ::: columns] 'Ungrouped '[]
162164 -- ^ condition to check
163− -> TableConstraint schema columns
164−check condition = UnsafeTableConstraint $
165+ -> TableConstraintExpression schema columns 'Check
166+check condition = UnsafeTableConstraintExpression $
165167 "CHECK" <+> parenthesized (renderExpression condition)
166168
167169-- | A `unique` constraint ensure that the data contained in a column,
@@ -179,8 +181,8 @@ unique
179181 :: SOP.SListI subcolumns
180182 => NP (Column columns) subcolumns
181183 -- ^ unique column or group of columns
182− -> TableConstraint schema columns
183−unique columns = UnsafeTableConstraint $
184+ -> TableConstraintExpression schema columns ( 'Uniques (Aliases subcolumns))
185+unique columns = UnsafeTableConstraintExpression $
184186 "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
185187
186188-- | A `primaryKey` constraint indicates that a column, or group of columns,
@@ -196,11 +198,11 @@ unique columns = UnsafeTableConstraint $
196198-- :}
197199-- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"
198200primaryKey
199− :: (SOP.SListI subcolumns, AllNotNull subcolumns)
201+ :: (SOP.SListI subcolumns, NotAllNull subcolumns)
200202 => NP (Column columns) subcolumns
201203 -- ^ identifying column or group of columns
202− -> TableConstraint schema columns
203−primaryKey columns = UnsafeTableConstraint $
204+ -> TableConstraintExpression schema columns ('Uniques (Aliases subcolumns))
205+primaryKey columns = UnsafeTableConstraintExpression $
204206 "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
205207
206208-- | A `foreignKey` specifies that the values in a column
@@ -237,14 +239,14 @@ primaryKey columns = UnsafeTableConstraint $
237239-- :}
238240-- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"
239241foreignKey
240− :: ( HasTable reftable schema refcolumns
242+ :: ( SchemaHasTable tab schema refcolumns
241243 , SameTypes subcolumns refsubcolumns
242244 , AllNotNull subcolumns
243245 , SOP.SListI subcolumns
244246 , SOP.SListI refsubcolumns)
245247 => NP (Column columns) subcolumns
246248 -- ^ column or columns in the table
247− -> Alias reftable
249+ -> Alias tab
248250 -- ^ reference table
249251 -> NP (Column refcolumns) refsubcolumns
250252 -- ^ reference column or columns in the reference table
@@ -252,9 +254,10 @@ foreignKey
252254 -- ^ what to do when reference is deleted
253255 -> OnUpdateClause
254256 -- ^ what to do when reference is updated
255− -> TableConstraint schema columns
257+ -> TableConstraintExpression schema columns
258+ ('ForeignKey (Aliases subcolumns) tab (Aliases refsubcolumns))
256259foreignKey columns reftable refcolumns onDelete onUpdate =
257− UnsafeTableConstraint $
260+ UnsafeTableConstraintExpression $
258261 "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
259262 <+> "REFERENCES" <+> renderAlias reftable
260263 <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
@@ -320,14 +323,14 @@ ALTER statements
320323
321324-- | `alterTable` changes the definition of a table from the schema.
322325alterTable
323− :: HasTable table schema columns0
324− => Alias table -- ^ table to alter
325− -> AlterColumns columns0 columns1 -- ^ alteration to perform
326− -> Definition schema (Alter table schema columns1)
326+ :: (KnownSymbol tab, (tab ::: table0) `In` schema)
327+ => Alias tab -- ^ table to alter
328+ -> AlterTable schema table0 table1 -- ^ alteration to perform
329+ -> Definition schema (Alter tab schema table1)
327330alterTable table alteration = UnsafeDefinition $
328331 "ALTER TABLE"
329332 <+> renderAlias table
330− <+> renderAlterColumns alteration
333+ <+> renderAlterTable alteration
331334 <> ";"
332335
333336-- | `alterTableRename` changes the name of a table from the schema.
@@ -354,21 +357,29 @@ alterTableRename table0 table1 = UnsafeDefinition $
354357-- in renderDefinition definition
355358-- :}
356359-- "ALTER TABLE tab ADD CHECK ((col > 0));"
357−alterTableAddConstraint
358− :: HasTable table schema columns
359− => Alias table -- ^ table to constrain
360− -> TableConstraint schema columns -- ^ what constraint to add
361− -> Definition schema schema
362−alterTableAddConstraint table constraint = UnsafeDefinition $
363− "ALTER TABLE" <+> renderAlias table
364− <+> "ADD" <+> renderTableConstraint constraint <> ";"
365−
366−-- | An `AlterColumns` describes the alteration to perform on the columns
360+-- alterTableAddConstraint
361+-- :: (HasTable table schema columns, (table ::: table0) `In` schema)
362+-- => Alias table -- ^ table to constrain
363+-- -> TableConstraintExpression schema columns constraint -- ^ what constraint to add
364+-- -> Definition schema (Alter table schema (AddConstraint constraint table0))
365+-- alterTableAddConstraint table constraint = UnsafeDefinition $
366+-- "ALTER TABLE" <+> renderAlias table
367+-- <+> "ADD" <+> renderTableConstraintExpression constraint <> ";"
368+
369+addConstraint
370+ :: (tab ::: table) `In` schema
371+ => Alias tab
372+ -> TableConstraintExpression schema columns constraint
373+ -> AlterTable schema table (AddConstraint constraint table)
374+addConstraint = undefined
375+
376+-- | An `AlterTable` describes the alteration to perform on the columns
367377-- of a table.
368−newtype AlterColumns
369− (columns0 :: ColumnsType)
370− (columns1 :: ColumnsType) =
371− UnsafeAlterColumns {renderAlterColumns :: ByteString}
378+newtype AlterTable
379+ (schema :: SchemaType)
380+ (table0 :: TableType)
381+ (table1 :: TableType) =
382+ UnsafeAlterTable {renderAlterTable :: ByteString}
372383 deriving (GHC.Generic,Show,Eq,Ord,NFData)
373384
374385-- | An `addColumnDefault` adds a new `Optional` column. The new column is
@@ -389,9 +400,9 @@ newtype AlterColumns
389400addColumnDefault
390401 :: (KnownSymbol column, 'Default `In` constraints)
391402 => Alias column -- ^ column to add
392− -> TypeExpression '(constraints, ty) -- ^ type of the new column
393− -> AlterColumns columns (Create column '(constraints, ty) columns)
394−addColumnDefault column ty = UnsafeAlterColumns $
403+ -> TypeExpression (constraints :=> ty) -- ^ type of the new column
404+ -> AlterTable schema table (Add column (constraints :=> ty) table)
405+addColumnDefault column ty = UnsafeAlterTable $
395406 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
396407
397408-- | An `addColumnNull` adds a new `Null` column. The new column is initially
@@ -411,9 +422,9 @@ addColumnDefault column ty = UnsafeAlterColumns $
411422addColumnNull
412423 :: KnownSymbol column
413424 => Alias column -- ^ column to add
414− -> TypeExpression '( '[], ('Null ty)) -- ^ type of the new column
415− -> AlterColumns columns (Create column '( '[], ('Null ty)) columns)
416−addColumnNull column ty = UnsafeAlterColumns $
425+ -> TypeExpression ( '[] :=> 'Null ty) -- ^ type of the new column
426+ -> AlterTable schema table (Add column ( '[] :=> 'Null ty) table)
427+addColumnNull column ty = UnsafeAlterTable $
417428 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
418429
419430-- | A `dropColumn` removes a column. Whatever data was in the column
@@ -435,8 +446,8 @@ addColumnNull column ty = UnsafeAlterColumns $
435446dropColumn
436447 :: KnownSymbol column
437448 => Alias column -- ^ column to remove
438− -> AlterColumns columns (Drop column columns)
439−dropColumn column = UnsafeAlterColumns $
449+ -> AlterTable schema ('[] :=> columns) ('[] :=> Drop column columns)
450+dropColumn column = UnsafeAlterTable $
440451 "DROP COLUMN" <+> renderAlias column
441452
442453-- | Like `dropColumn` but authorizes dropping everything that depends
@@ -453,12 +464,12 @@ dropColumn column = UnsafeAlterColumns $
453464-- in renderDefinition definition
454465-- :}
455466-- "ALTER TABLE tab DROP COLUMN col2 CASCADE;"
456−dropColumnCascade
457− :: KnownSymbol column
458− => Alias column -- ^ column to remove
459− -> AlterColumns columns (Drop column columns)
460−dropColumnCascade column = UnsafeAlterColumns $
461− "DROP COLUMN" <+> renderAlias column <+> "CASCADE"
467+-- dropColumnCascade
468+-- :: KnownSymbol column
469+-- => Alias column -- ^ column to remove
470+-- -> AlterTable schema columns (Drop column columns)
471+-- dropColumnCascade column = UnsafeAlterTable $
472+-- "DROP COLUMN" <+> renderAlias column <+> "CASCADE"
462473
463474-- | A `renameColumn` renames a column.
464475--
@@ -475,8 +486,9 @@ renameColumn
475486 :: (KnownSymbol column0, KnownSymbol column1)
476487 => Alias column0
477488 -> Alias column1
478− -> AlterColumns columns (Rename column0 column1 columns)
479−renameColumn column0 column1 = UnsafeAlterColumns $
489+ -> AlterTable schema ('[] :=> columns)
490+ ('[] :=> Rename column0 column1 columns)
491+renameColumn column0 column1 = UnsafeAlterTable $
480492 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
481493
482494-- | An `alterColumn` alters a single column.
@@ -484,8 +496,8 @@ alterColumn
484496 :: (KnownSymbol column, HasColumn column columns ty0)
485497 => Alias column -- ^ column to alter
486498 -> AlterColumn ty0 ty1 -- ^ alteration to perform
487− -> AlterColumns columns (Alter column columns ty1)
488−alterColumn column alteration = UnsafeAlterColumns $
499+ -> AlterTable schema ('[] :=> columns) ('[] :=> Alter column columns ty1)
500+alterColumn column alteration = UnsafeAlterTable $
489501 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
490502
491503-- | An `AlterColumn` describes the alteration to perform on a single column.
@@ -523,7 +535,7 @@ setDefault expression = UnsafeAlterColumn $
523535-- in renderDefinition definition
524536-- :}
525537-- "ALTER TABLE tab ALTER COLUMN col DROP DEFAULT;"
526−dropDefault :: AlterColumn '(constraints, ty) '(DropDefault constraints, ty)
538+dropDefault :: AlterColumn ty (DropConstraint 'Default ty)
527539dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
528540
529541-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+14−5
@@ -105,6 +105,7 @@ module Squeal.PostgreSQL.Expression
105105 -- * Tables
106106 , Table (UnsafeTable, renderTable)
107107 , HasTable (getTable)
108+ , SchemaHasTable
108109 -- * TypeExpression
109110 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
110111 , PGTyped (pgtype)
@@ -181,7 +182,7 @@ values from primitive expression using arithmetic, logical,
181182and other operations.
182183-}
183184newtype Expression
184− (tables :: TablesType)
185+ (tables :: RelationType)
185186 (grouping :: Grouping)
186187 (params :: [ColumnType])
187188 (ty :: ColumnType)
@@ -978,7 +979,7 @@ tables
978979-- | A `Table` from a schema without its alias with an `IsLabel` instance
979980-- to call a table reference by its alias.
980981newtype Table
981− (schema :: TablesType)
982+ (schema :: RelationType)
982983 (columns :: ColumnsType)
983984 = UnsafeTable { renderTable :: ByteString }
984985 deriving (GHC.Generic,Show,Eq,Ord,NFData)
@@ -998,6 +999,14 @@ instance HasTable table schema columns
998999 => IsLabel table (Table schema columns) where
9991000 fromLabel = getTable (Alias @table)
10001001
1002+type family SchemaHasTable
1003+ (table :: Symbol)
1004+ (schema :: SchemaType)
1005+ (columns :: ColumnsType)
1006+ where
1007+ SchemaHasTable table schema columns =
1008+ HasTable table (UnconstrainOver schema) columns
1009+
10011010{-----------------------------------------
10021011type expressions
10031012-----------------------------------------}
@@ -1037,19 +1046,19 @@ doublePrecision = UnsafeTypeExpression "double precision"
10371046-- | not a true type, but merely a notational convenience for creating
10381047-- unique identifier columns with type `'PGint2`
10391048serial2, smallserial
1040− :: TypeExpression ( '[ 'Default, 'Unique] :=> 'NotNull 'PGint2)
1049+ :: TypeExpression ( AsSet '[ 'Default, 'Unique] :=> 'NotNull 'PGint2)
10411050serial2 = UnsafeTypeExpression "serial2"
10421051smallserial = UnsafeTypeExpression "smallserial"
10431052-- | not a true type, but merely a notational convenience for creating
10441053-- unique identifier columns with type `'PGint4`
10451054serial4, serial
1046− :: TypeExpression ( '[Default, 'Unique] :=> 'NotNull 'PGint4)
1055+ :: TypeExpression ( AsSet '[ 'Default, 'Unique] :=> 'NotNull 'PGint4)
10471056serial4 = UnsafeTypeExpression "serial4"
10481057serial = UnsafeTypeExpression "serial"
10491058-- | not a true type, but merely a notational convenience for creating
10501059-- unique identifier columns with type `'PGint8`
10511060serial8, bigserial
1052− :: TypeExpression ( '[ 'Default, 'Unique] :=> 'NotNull 'PGint8)
1061+ :: TypeExpression ( AsSet '[ 'Default, 'Unique] :=> 'NotNull 'PGint8)
10531062serial8 = UnsafeTypeExpression "serial8"
10541063bigserial = UnsafeTypeExpression "bigserial"
10551064-- | variable-length character string
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+9−5
@@ -12,6 +12,7 @@ Squeal data manipulation language.
1212 DataKinds
1313 , DeriveDataTypeable
1414 , DeriveGeneric
15+ , FlexibleContexts
1516 , GADTs
1617 , GeneralizedNewtypeDeriving
1718 , KindSignatures
@@ -59,7 +60,7 @@ import Squeal.PostgreSQL.Schema
5960-- `deleteFrom`. A `Query` is also considered a `Manipulation` even though
6061-- it does not modify data.
6162newtype Manipulation
62− (schema :: TablesType)
63+ (schema :: SchemaType)
6364 (params :: [ColumnType])
6465 (columns :: ColumnsType)
6566 = UnsafeManipulation { renderManipulation :: ByteString }
@@ -177,7 +178,8 @@ in renderManipulation manipulation
177178"INSERT INTO tab (col1, col2) VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET col1 = 2 WHERE (col1 = col2) RETURNING (col1 + col2) AS sum;"
178179-}
179180insertInto
180− :: (SOP.SListI columns, SOP.SListI results, HasTable table schema columns)
181+ :: ( SOP.SListI columns, SOP.SListI results
182+ , SchemaHasTable table schema columns )
181183 => Alias table -- ^ table to insert into
182184 -> ValuesClause schema params columns -- ^ values to insert
183185 -> ConflictClause columns params
@@ -193,7 +195,7 @@ insertInto table insert conflict returning = UnsafeManipulation $
193195-- | A `ValuesClause` lets you insert either values, free `Expression`s,
194196-- or the result of a `Query`.
195197data ValuesClause
196− (schema :: TablesType)
198+ (schema :: SchemaType)
197199 (params :: [ColumnType])
198200 (columns :: ColumnsType)
199201 = Values
@@ -301,7 +303,9 @@ UPDATE statements
301303-- :}
302304-- "UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"
303305update
304− :: (HasTable table schema columns, SOP.SListI columns, SOP.SListI results)
306+ :: ( SchemaHasTable table schema columns
307+ , SOP.SListI columns
308+ , SOP.SListI results )
305309 => Alias table -- ^ table to update
306310 -> NP (Aliased (UpdateExpression columns params)) columns
307311 -- ^ modified values to replace old values
@@ -356,7 +360,7 @@ DELETE statements
356360-- :}
357361-- "DELETE FROM tab WHERE (col1 = col2) RETURNING *;"
358362deleteFrom
359− :: (SOP.SListI results, HasTable table schema columns)
363+ :: (SOP.SListI results, SchemaHasTable table schema columns)
360364 => Alias table -- ^ table to delete from
361365 -> Condition '[table ::: columns] 'Ungrouped params
362366 -- ^ condition under which to delete a row
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+4−4
@@ -100,8 +100,8 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy
100100import qualified Control.Monad.Trans.RWS.Strict as Strict
101101
102102-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`
103−-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`
104−newtype Connection (schema :: TablesType) =
103+-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `SchemaType`
104+newtype Connection (schema :: SchemaType) =
105105 Connection { unConnection :: LibPQ.Connection }
106106
107107{- | Makes a new connection to the database server.
@@ -153,8 +153,8 @@ withConnection connString action = do
153153-- | We keep track of the schema via an Atkey indexed state monad transformer,
154154-- `PQ`.
155155newtype PQ
156− (schema0 :: TablesType)
157− (schema1 :: TablesType)
156+ (schema0 :: SchemaType)
157+ (schema1 :: SchemaType)
158158 (m :: Type -> Type)
159159 (x :: Type) =
160160 PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+5−5
@@ -257,7 +257,7 @@ in renderQuery query
257257-}
258258
259259newtype Query
260− (schema :: TablesType)
260+ (schema :: SchemaType)
261261 (params :: [ColumnType])
262262 (columns :: ColumnsType)
263263 = UnsafeQuery { renderQuery :: ByteString }
@@ -419,9 +419,9 @@ Table Expressions
419419-- to a table on disk, a so-called base table, but more complex expressions
420420-- can be used to modify or combine base tables in various ways.
421421data TableExpression
422− (schema :: TablesType)
422+ (schema :: SchemaType)
423423 (params :: [ColumnType])
424− (tables :: TablesType)
424+ (tables :: RelationType)
425425 (grouping :: Grouping)
426426 = TableExpression
427427 { fromClause :: FromClause schema params tables
@@ -612,7 +612,7 @@ their placement in SQL.
612612-}
613613data FromClause schema params tables where
614614 Table
615− :: Aliased (Table schema) table
615+ :: Aliased (Table (UnconstrainOver schema)) table
616616 -> FromClause schema params '[table]
617617 Subquery
618618 :: Aliased (Query schema params) table
@@ -669,7 +669,7 @@ Grouping
669669-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
670670-- qualified column @tab.col@.
671671data By
672− (tables :: TablesType)
672+ (tables :: RelationType)
673673 (by :: (Symbol,Symbol)) where
674674 By
675675 :: (HasUnique table tables columns, HasColumn column columns ty)
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+65−26
@@ -28,6 +28,7 @@ Embedding of PostgreSQL type and alias system
2828 , TypeFamilies
2929 , TypeInType
3030 , TypeOperators
31+ , UndecidableInstances
3132#-}
3233
3334module Squeal.PostgreSQL.Schema
@@ -36,8 +37,9 @@ module Squeal.PostgreSQL.Schema
3637 , NullityType (..)
3738 , ColumnType
3839 , ColumnsType
40+ , RelationType
3941 , TableType
40− , TablesType
42+ , SchemaType
4143 , Grouping (..)
4244 -- * Constraints
4345 , PGNum
@@ -63,6 +65,7 @@ module Squeal.PostgreSQL.Schema
6365 , NullifyTables
6466 , Join
6567 , Create
68+ , Add
6669 , Drop
6770 , Alter
6871 , Rename
@@ -71,18 +74,24 @@ module Squeal.PostgreSQL.Schema
7174 , SameFields
7275 -- * PostgreSQL Constraints
7376 , (:=>)
74− , (::=>)
7577 , Unconstrain
78+ , UnconstrainOver
7679 , ColumnConstraint (..)
77− , DropDefault
78− , DropDefaultList
79− , TableConstraint' (..)
80+ -- , DropDefault
81+ -- , DropDefaultList
82+ , AddConstraint
83+ , DropConstraint
84+ , TableConstraint (..)
85+ , AsSet
86+ , Aliases
8087 ) where
8188
8289import Control.DeepSeq
8390import Data.ByteString
8491import Data.Monoid
8592import Data.String
93+import Data.Type.Bool
94+import Data.Type.Equality
8695import Data.Type.Set
8796import Generics.SOP (AllZip)
8897import GHC.Generics (Generic)
@@ -133,13 +142,22 @@ type ColumnType = ([ColumnConstraint],NullityType)
133142-- | `ColumnsType` is a kind synonym for a row of `ColumnType`s.
134143type ColumnsType = [(Symbol,ColumnType)]
135144
136−type TableType = ([TableConstraint'],ColumnsType)
137−
138−-- | `TablesType` is a kind synonym for a row of `ColumnsType`s.
145+-- | `RelationType` is a kind synonym for a row of `ColumnsType`s.
139146-- It is used as a kind for both a schema, a disjoint union of tables,
140147-- and a joined table `Squeal.PostgreSQL.Query.FromClause`,
141148-- a product of tables.
142−type TablesType = [(Symbol,ColumnsType)]
149+type RelationType = [(Symbol,ColumnsType)]
150+
151+type TableType = ([TableConstraint],ColumnsType)
152+type SchemaType = [(Symbol,TableType)]
153+
154+type family Unconstrain (ty :: ([constraint],kind)) :: kind where
155+ Unconstrain '(constraints,ty) = ty
156+
157+type family UnconstrainOver (tys :: SchemaType) :: RelationType where
158+ UnconstrainOver '[] = '[]
159+ UnconstrainOver ((alias ::: x) ': xs) =
160+ (alias ::: Unconstrain x) ': UnconstrainOver xs
143161
144162-- | `Grouping` is an auxiliary namespace, created by
145163-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
@@ -168,6 +186,7 @@ type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
168186-- an alias and some type, usually a column alias and a `ColumnType` or
169187-- a table alias and a `ColumnsType`.
170188type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)
189+infixr 6 :::
171190
172191-- | `Alias`es are proxies for a type level string or `Symbol`
173192-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
@@ -270,10 +289,10 @@ type family NullifyColumns (columns :: ColumnsType) :: ColumnsType where
270289type family NullifyTable (table :: TableType) :: TableType where
271290 NullifyTable '( '[], columns) = '( '[], NullifyColumns columns)
272291
273−-- | `NullifyTables` is an idempotent that nullifies a `TablesType`
292+-- | `NullifyTables` is an idempotent that nullifies a `RelationType`
274293-- used to nullify the left or right hand side of an outer join
275294-- in a `Squeal.PostgreSQL.Query.FromClause`.
276−type family NullifyTables (tables :: TablesType) :: TablesType where
295+type family NullifyTables (tables :: RelationType) :: RelationType where
277296 NullifyTables '[] = '[]
278297 NullifyTables ((tab ::: columns) ': tables) =
279298 (tab ::: NullifyColumns columns) ': NullifyTables tables
@@ -292,6 +311,9 @@ type family Create alias x xs where
292311 Create alias x '[] = '[alias ::: x]
293312 Create alias y (x ': xs) = x ': Create alias y xs
294313
314+type family Add alias x y where
315+ Add alias x (constraints :=> xs) = constraints :=> Create alias x xs
316+
295317-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
296318-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
297319-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
@@ -306,6 +328,19 @@ type family Alter alias xs x where
306328 Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
307329 Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
308330
331+type family AddConstraint constraint ty where
332+ AddConstraint constraint (constraints :=> ty)
333+ = AsSet (constraint ': constraints) :=> ty
334+
335+type family DeleteFromList (e :: elem) (list :: [elem]) where
336+ DeleteFromList elem '[] = '[]
337+ DeleteFromList elem (x ': xs) =
338+ If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)
339+
340+type family DropConstraint constraint ty where
341+ DropConstraint constraint (constraints :=> ty)
342+ = (AsSet (DeleteFromList constraint constraints)) :=> ty
343+
309344-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
310345-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
311346-- `Squeal.PostgreSQL.Definition.renameColumn`.
@@ -334,26 +369,30 @@ type family SameFields
334369 columns
335370 = AllZip SameField fields columns
336371
337−type (:=>) constraints ty = '(constraints,ty)
338−type (::=>) constraints ty = '(AsSet constraints,ty)
339−
340−type family Unconstrain constrained where
341− Unconstrain '(constraints, ty) = '( '[], ty)
372+type (:=>) (constraints :: [constraint]) ty = '(constraints,ty)
373+infixr 7 :=>
342374
343375data ColumnConstraint
344376 = Default
345377 | Unique
346378 | References Symbol Symbol
347379
348−type DropDefault constraints = AsSet (DropDefaultList constraints)
349−
350−type family DropDefaultList constraints where
351− DropDefaultList '[] = '[]
352− DropDefaultList ( 'Default ': constraints) = constraints
353− DropDefaultList (constraint ': constraints) =
354− constraint ': DropDefaultList constraints
355−
356−data TableConstraint'
357− = Check [Symbol]
380+type instance Cmp 'Default 'Default = 'EQ
381+type instance Cmp 'Unique 'Unique = 'EQ
382+type instance Cmp ('References tab0 col0) ('References tab1 col1) =
383+ If (Cmp tab0 tab1 == 'EQ) (Cmp col0 col1) (Cmp tab0 tab1)
384+type instance Cmp 'Default 'Unique = 'LT
385+type instance Cmp 'Unique 'Default = 'GT
386+type instance Cmp 'Default ('References tab col) = 'LT
387+type instance Cmp ('References tab col) 'Default = 'GT
388+type instance Cmp 'Unique ('References tab col) = 'LT
389+type instance Cmp ('References tab col) 'Unique = 'GT
390+
391+data TableConstraint
392+ = Check
358393 | Uniques [Symbol]
359394 | ForeignKey [Symbol] Symbol [Symbol]
395+
396+type family Aliases xs where
397+ Aliases '[] = '[]
398+ Aliases ((alias ::: x) ': xs) = alias ': Aliases xs