git.iko.soy/squeal
on dev help sign in
resolve #27

Attempt to resolve #27 * introduce new typeclass `HasAll` which proves a subfield relation * remove `Column` datatype! * remove `ForeignKeyed` constraint synonym * change the kind of `Alter` type family to be more consistent * add `SamePGType` constraint * Change the kind of `TableConstraintExpression`

commit8ca416a315de17943eba44676c2ab1b2ee84718d authorEitan Chatav <eitan.chatav@gmail.com> dateSun 8 Apr 2018, 21:53 (9 years ago) parenta15c7b6
6 files changed+177−121
compare with dev
unifiedsplit
README.md+3−3 squeal-postgresql/exe/Example.hs+3−3 squeal-postgresql/src/Squeal/PostgreSQL.hs+3−3 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+124−98 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+4−4 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+40−10
README.md+3−3
@@ -128,13 +128,13 @@ let
128128 createTable #users
129129 ( serial `As` #id :*
130130 (text & notNull) `As` #name :* Nil )
131− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
131+ ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>>
132132 createTable #emails
133133 ( serial `As` #id :*
134134 (int & notNull) `As` #user_id :*
135135 text `As` #email :* Nil )
136− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
137− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
136+ ( primaryKey (#id :* Nil) `As` #pk_emails :*
137+ foreignKey (#user_id :* Nil) #users (#id :* Nil)
138138 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
139139:}
140140```
squeal-postgresql/exe/Example.hs+3−3
@@ -47,14 +47,14 @@ setup =
4747 ( serial `As` #id :*
4848 (text & notNull) `As` #name :*
4949 (vararray int2 & notNull) `As` #vec :* Nil )
50− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
50+ ( primaryKey (#id :* Nil) `As` #pk_users :* Nil )
5151 >>>
5252 createTable #emails
5353 ( serial `As` #id :*
5454 (int & notNull) `As` #user_id :*
5555 text `As` #email :* Nil )
56− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
57− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
56+ ( primaryKey (#id :* Nil) `As` #pk_emails :*
57+ foreignKey (#user_id :* Nil) #users (#id :* Nil)
5858 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
5959
6060teardown :: Definition Schema '[]
squeal-postgresql/src/Squeal/PostgreSQL.hs+3−3
@@ -67,13 +67,13 @@
6767-- createTable #users
6868-- ( serial `As` #id :*
6969-- (text & notNull) `As` #name :* Nil )
70−-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
70+-- ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>>
7171-- createTable #emails
7272-- ( serial `As` #id :*
7373-- (int & notNull) `As` #user_id :*
7474-- text `As` #email :* Nil )
75−-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
76−-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
75+-- ( primaryKey (#id :* Nil) `As` #pk_emails :*
76+-- foreignKey (#user_id :* Nil) #users (#id :* Nil)
7777-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
7878-- :}
7979--
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+124−98
@@ -37,12 +37,10 @@ module Squeal.PostgreSQL.Definition
3737 , createTable
3838 , createTableIfNotExists
3939 , TableConstraintExpression (..)
40− , Column (..)
4140 , check
4241 , unique
4342 , primaryKey
4443 , foreignKey
45− , ForeignKeyed
4644 , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
4745 , renderOnDeleteClause
4846 , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
@@ -115,13 +113,14 @@ createTable
115113 :: ( KnownSymbol table
116114 , columns ~ (col ': cols)
117115 , SOP.SListI columns
118− , SOP.SListI constraints )
116+ , SOP.SListI constraints
117+ , schema1 ~ Create table (constraints :=> columns) schema0 )
119118 => Alias table -- ^ the name of the table to add
120119 -> NP (Aliased TypeExpression) columns
121120 -- ^ the names and datatype of each column
122− -> NP (Aliased (TableConstraintExpression schema columns)) constraints
121+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints
123122 -- ^ constraints that must hold for the table
124− -> Definition schema (Create table (constraints :=> columns) schema)
123+ -> Definition schema0 schema1
125124createTable table columns constraints = UnsafeDefinition $
126125 "CREATE TABLE" <+> renderCreation table columns constraints
127126
@@ -144,7 +143,7 @@ createTableIfNotExists
144143 => Alias table -- ^ the name of the table to add
145144 -> NP (Aliased TypeExpression) columns
146145 -- ^ the names and datatype of each column
147− -> NP (Aliased (TableConstraintExpression schema columns)) constraints
146+ -> NP (Aliased (TableConstraintExpression schema table)) constraints
148147 -- ^ constraints that must hold for the table
149148 -> Definition schema schema
150149createTableIfNotExists table columns constraints = UnsafeDefinition $
@@ -159,7 +158,7 @@ renderCreation
159158 => Alias table -- ^ the name of the table to add
160159 -> NP (Aliased TypeExpression) columns
161160 -- ^ the names and datatype of each column
162− -> NP (Aliased (TableConstraintExpression schema columns)) constraints
161+ -> NP (Aliased (TableConstraintExpression schema table)) constraints
163162 -- ^ constraints that must hold for the table
164163 -> ByteString
165164renderCreation table columns constraints = renderAlias table
@@ -194,43 +193,41 @@ renderCreation table columns constraints = renderAlias table
194193-- even if the value came from the default value definition.
195194newtype TableConstraintExpression
196195 (schema :: TablesType)
197− (columns :: ColumnsType)
196+ (table :: Symbol)
198197 (tableConstraint :: TableConstraint)
199198 = UnsafeTableConstraintExpression
200199 { renderTableConstraintExpression :: ByteString }
201200 deriving (GHC.Generic,Show,Eq,Ord,NFData)
202201
203−-- | @Column columns column@ is a witness that `column` is in `columns`.
204−data Column
205− (columns :: ColumnsType)
206− (column :: (Symbol,ColumnType))
207− where
208− Column
209− :: Has column columns ty
210− => Alias column
211− -> Column columns (column ::: ty)
212−
213−-- | Render a `Column`.
214−renderColumn :: Column columns column -> ByteString
215−renderColumn (Column column) = renderAlias column
216−
217202-- | A `check` constraint is the most generic `TableConstraint` type.
218203-- It allows you to specify that the value in a certain column must satisfy
219204-- a Boolean (truth-value) expression.
220205--
221206-- >>> :{
222−-- renderDefinition $
223−-- createTable #tab
207+-- type Schema = '[
208+-- "tab" ::: '[ "inequality" ::: 'Check '["a","b"]] :=> '[
209+-- "a" ::: 'NoDef :=> 'NotNull 'PGint4,
210+-- "b" ::: 'NoDef :=> 'NotNull 'PGint4
211+-- ]]
212+-- :}
213+--
214+-- >>> :{
215+-- let
216+-- definition :: Definition '[] Schema
217+-- definition = createTable #tab
224218-- ( (int & notNull) `As` #a :*
225219-- (int & notNull) `As` #b :* Nil )
226−-- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil )
220+-- ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil )
227221-- :}
222+--
223+-- >>> renderDefinition definition
228224-- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));"
229225check
230− :: NP (Column columns) subcolumns
231− -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[]
232− -- ^ condition to check
233− -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns))
226+ :: ( Has alias schema table
227+ , HasAll aliases (TableToColumns table) subcolumns )
228+ => NP Alias aliases
229+ -> (forall tab. Condition '[tab ::: ColumnsToRelation subcolumns] 'Ungrouped '[])
230+ -> TableConstraintExpression schema alias ('Check aliases)
234231check _cols condition = UnsafeTableConstraintExpression $
235232 "CHECK" <+> parenthesized (renderExpression condition)
236233
@@ -238,40 +235,62 @@ check _cols condition = UnsafeTableConstraintExpression $
238235-- or a group of columns, is unique among all the rows in the table.
239236--
240237-- >>> :{
241−-- renderDefinition $
242−-- createTable #tab
238+-- type Schema = '[
239+-- "tab" ::: '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
240+-- "a" ::: 'NoDef :=> 'Null 'PGint4,
241+-- "b" ::: 'NoDef :=> 'Null 'PGint4
242+-- ]]
243+-- :}
244+--
245+-- >>> :{
246+-- let
247+-- definition :: Definition '[] Schema
248+-- definition = createTable #tab
243249-- ( int `As` #a :*
244250-- int `As` #b :* Nil )
245−-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )
251+-- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil )
246252-- :}
253+--
254+-- >>> renderDefinition definition
247255-- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));"
248256unique
249− :: SOP.SListI subcolumns
250− => NP (Column columns) subcolumns
251− -- ^ unique column or group of columns
252− -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns))
257+ :: ( Has alias schema table
258+ , HasAll aliases (TableToColumns table) subcolumns )
259+ => NP Alias aliases
260+ -> TableConstraintExpression schema alias ('Unique aliases)
253261unique columns = UnsafeTableConstraintExpression $
254− "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
262+ "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))
255263
256264-- | A `primaryKey` constraint indicates that a column, or group of columns,
257265-- can be used as a unique identifier for rows in the table.
258266-- This requires that the values be both unique and not null.
259267--
260268-- >>> :{
261−-- renderDefinition $
262−-- createTable #tab
269+-- type Schema = '[
270+-- "tab" ::: '[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
271+-- "id" ::: 'Def :=> 'NotNull 'PGint4,
272+-- "name" ::: 'NoDef :=> 'NotNull 'PGtext
273+-- ]]
274+-- :}
275+--
276+-- >>> :{
277+-- let
278+-- definition :: Definition '[] Schema
279+-- definition = createTable #tab
263280-- ( serial `As` #id :*
264281-- (text & notNull) `As` #name :* Nil )
265−-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )
282+-- ( primaryKey (#id :* Nil) `As` #pk_id :* Nil )
266283-- :}
284+--
285+-- >>> renderDefinition definition
267286-- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));"
268287primaryKey
269− :: (SOP.SListI subcolumns, AllNotNull subcolumns)
270− => NP (Column columns) subcolumns
271− -- ^ identifying column or group of columns
272− -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns))
288+ :: ( Has alias schema table
289+ , HasAll aliases (TableToColumns table) subcolumns )
290+ => NP Alias aliases
291+ -> TableConstraintExpression schema alias ('PrimaryKey aliases)
273292primaryKey columns = UnsafeTableConstraintExpression $
274− "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
293+ "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))
275294
276295-- | A `foreignKey` specifies that the values in a column
277296-- (or a group of columns) must match the values appearing in some row of
@@ -303,46 +322,41 @@ primaryKey columns = UnsafeTableConstraintExpression $
303322-- createTable #users
304323-- ( serial `As` #id :*
305324-- (text & notNull) `As` #name :* Nil )
306−-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
325+-- ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>>
307326-- createTable #emails
308327-- ( serial `As` #id :*
309328-- (int & notNull) `As` #user_id :*
310329-- text `As` #email :* Nil )
311−-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
312−-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
330+-- ( primaryKey (#id :* Nil) `As` #pk_emails :*
331+-- foreignKey (#user_id :* Nil) #users (#id :* Nil)
313332-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
314333-- in renderDefinition setup
315334-- :}
316335-- "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, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);"
317336foreignKey
318− :: ForeignKeyed schema table reftable subcolumns refsubcolumns
319− => NP (Column columns) subcolumns
337+ :: ( Has child schema table
338+ , Has parent schema reftable
339+ , HasAll columns (TableToColumns table) tys
340+ , HasAll refcolumns (TableToColumns reftable) reftys
341+ , SOP.AllZip SamePGType tys reftys )
342+ => NP Alias columns
320343 -- ^ column or columns in the table
321− -> Alias table
344+ -> Alias parent
322345 -- ^ reference table
323− -> NP (Column (TableToColumns reftable)) refsubcolumns
346+ -> NP Alias refcolumns
324347 -- ^ reference column or columns in the reference table
325348 -> OnDeleteClause
326349 -- ^ what to do when reference is deleted
327350 -> OnUpdateClause
328351 -- ^ what to do when reference is updated
329− -> TableConstraintExpression schema columns
330− ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns))
331−foreignKey columns reftable refcolumns onDelete onUpdate =
332− UnsafeTableConstraintExpression $
333− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
334− <+> "REFERENCES" <+> renderAlias reftable
335− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
336− <+> renderOnDeleteClause onDelete
337− <+> renderOnUpdateClause onUpdate
338−
339−-- | A type synonym for constraints on a table with a foreign key.
340−type ForeignKeyed schema table reftable subcolumns refsubcolumns
341− = ( Has table schema reftable
342− , SameTypes subcolumns refsubcolumns
343− , AllNotNull subcolumns
344− , SOP.SListI subcolumns
345− , SOP.SListI refsubcolumns )
352+ -> TableConstraintExpression schema child
353+ ('ForeignKey columns parent refcolumns)
354+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
355+ "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))
356+ <+> "REFERENCES" <+> renderAlias parent
357+ <+> parenthesized (commaSeparated (renderAliases refs))
358+ <+> renderOnDeleteClause ondel
359+ <+> renderOnUpdateClause onupd
346360
347361-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
348362data OnDeleteClause
@@ -403,10 +417,10 @@ ALTER statements
403417
404418-- | `alterTable` changes the definition of a table from the schema.
405419alterTable
406− :: Has tab schema table0
407− => Alias tab -- ^ table to alter
408− -> AlterTable schema table0 table1 -- ^ alteration to perform
409− -> Definition schema (Alter tab schema table1)
420+ :: KnownSymbol alias
421+ => Alias alias -- ^ table to alter
422+ -> AlterTable alias table schema -- ^ alteration to perform
423+ -> Definition schema (Alter alias table schema)
410424alterTable table alteration = UnsafeDefinition $
411425 "ALTER TABLE"
412426 <+> renderAlias table
@@ -429,9 +443,9 @@ alterTableRename table0 table1 = UnsafeDefinition $
429443-- | An `AlterTable` describes the alteration to perform on the columns
430444-- of a table.
431445newtype AlterTable
432− (schema :: TablesType)
433− (table0 :: TableType)
434− (table1 :: TableType) =
446+ (alias :: Symbol)
447+ (table :: TableType)
448+ (schema :: TablesType) =
435449 UnsafeAlterTable {renderAlterTable :: ByteString}
436450 deriving (GHC.Generic,Show,Eq,Ord,NFData)
437451
@@ -442,17 +456,19 @@ newtype AlterTable
442456-- definition :: Definition
443457-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
444458-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
445−-- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0)))
459+-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0)))
446460-- in renderDefinition definition
447461-- :}
448462-- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));"
449463addConstraint
450− :: KnownSymbol alias
464+ :: ( KnownSymbol alias
465+ , Has tab schema table0
466+ , table0 ~ (constraints :=> columns)
467+ , table1 ~ (Create alias constraint constraints :=> columns) )
451468 => Alias alias
452− -> TableConstraintExpression schema columns constraint
469+ -> TableConstraintExpression schema tab constraint
453470 -- ^ constraint to add
454− -> AlterTable schema (constraints :=> columns)
455− (Create alias constraint constraints :=> columns)
471+ -> AlterTable tab table1 schema
456472addConstraint alias constraint = UnsafeAlterTable $
457473 "ADD" <+> "CONSTRAINT" <+> renderAlias alias
458474 <+> renderTableConstraintExpression constraint
@@ -469,12 +485,13 @@ addConstraint alias constraint = UnsafeAlterTable $
469485-- :}
470486-- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";"
471487dropConstraint
472− :: KnownSymbol constraint
488+ :: ( KnownSymbol constraint
489+ , Has tab schema table0
490+ , table0 ~ (constraints :=> columns)
491+ , table1 ~ (Drop constraint constraints :=> columns) )
473492 => Alias constraint
474493 -- ^ constraint to drop
475− -> AlterTable schema
476− (constraints :=> columns)
477− (Drop constraint constraints :=> columns)
494+ -> AlterTable tab table1 schema
478495dropConstraint constraint = UnsafeAlterTable $
479496 "DROP" <+> "CONSTRAINT" <+> renderAlias constraint
480497
@@ -507,11 +524,13 @@ class AddColumn ty where
507524 -- :}
508525 -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;"
509526 addColumn
510− :: KnownSymbol column
527+ :: ( KnownSymbol column
528+ , Has tab schema table0
529+ , table0 ~ (constraints :=> columns)
530+ , table1 ~ (constraints :=> Create column ty columns) )
511531 => Alias column -- ^ column to add
512532 -> TypeExpression ty -- ^ type of the new column
513− -> AlterTable schema (constraints :=> columns)
514− (constraints :=> Create column ty columns)
533+ -> AlterTable tab table1 schema
515534 addColumn column ty = UnsafeAlterTable $
516535 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
517536instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
@@ -534,11 +553,12 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
534553-- :}
535554-- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";"
536555dropColumn
537− :: KnownSymbol column
556+ :: ( KnownSymbol column
557+ , Has tab schema table0
558+ , table0 ~ (constraints :=> columns)
559+ , table1 ~ (constraints :=> Drop column columns) )
538560 => Alias column -- ^ column to remove
539− -> AlterTable schema
540− (constraints :=> columns)
541− (DropIfConstraintsInvolve column constraints :=> Drop column columns)
561+ -> AlterTable tab table1 schema
542562dropColumn column = UnsafeAlterTable $
543563 "DROP COLUMN" <+> renderAlias column
544564
@@ -554,21 +574,27 @@ dropColumn column = UnsafeAlterTable $
554574-- :}
555575-- "ALTER TABLE \"tab\" RENAME COLUMN \"foo\" TO \"bar\";"
556576renameColumn
557− :: (KnownSymbol column0, KnownSymbol column1)
577+ :: ( KnownSymbol column0
578+ , KnownSymbol column1
579+ , Has tab schema table0
580+ , table0 ~ (constraints :=> columns)
581+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
558582 => Alias column0 -- ^ column to rename
559583 -> Alias column1 -- ^ what to rename the column
560− -> AlterTable schema (constraints :=> columns)
561− (constraints :=> Rename column0 column1 columns)
584+ -> AlterTable tab table1 schema
562585renameColumn column0 column1 = UnsafeAlterTable $
563586 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
564587
565588-- | An `alterColumn` alters a single column.
566589alterColumn
567− :: (KnownSymbol column, Has column columns ty0)
590+ :: ( KnownSymbol column
591+ , Has tab schema table0
592+ , table0 ~ (constraints :=> columns)
593+ , Has column columns ty0
594+ , tables1 ~ (constraints :=> Alter column ty1 columns))
568595 => Alias column -- ^ column to alter
569596 -> AlterColumn ty0 ty1 -- ^ alteration to perform
570− -> AlterTable schema (constraints :=> columns)
571− (constraints :=> Alter column columns ty1)
597+ -> AlterTable tab table1 schema
572598alterColumn column alteration = UnsafeAlterTable $
573599 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
574600
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+4−4
@@ -38,7 +38,7 @@ let
3838 createTable #users
3939 ( serial `As` #id :*
4040 (text & notNull) `As` #name :* Nil )
41− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
41+ ( primaryKey (#id :* Nil) `As` #pk_users :* Nil )
4242 , down = void . define $ dropTable #users
4343 }
4444:}
@@ -54,8 +54,8 @@ let
5454 ( serial `As` #id :*
5555 (int & notNull) `As` #user_id :*
5656 text `As` #email :* Nil )
57− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
58− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
57+ ( primaryKey (#id :* Nil) `As` #pk_emails :*
58+ foreignKey (#user_id :* Nil) #users (#id :* Nil)
5959 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
6060 , down = void . define $ dropTable #emails
6161 }
@@ -290,7 +290,7 @@ createMigrations =
290290 ( (text & notNull) `As` #name :*
291291 (timestampWithTimeZone & notNull & default_ currentTimestamp)
292292 `As` #executed_at :* Nil )
293− ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )
293+ ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil )
294294
295295-- | Inserts a `Migration` into the `MigrationsTable`
296296insertMigration
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+40−10
@@ -31,6 +31,7 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.
3131 , TypeInType
3232 , TypeOperators
3333 , UndecidableInstances
34+ , UndecidableSuperClasses
3435#-}
3536
3637module Squeal.PostgreSQL.Schema
@@ -59,11 +60,13 @@ module Squeal.PostgreSQL.Schema
5960 , (:::)
6061 , Alias (Alias)
6162 , renderAlias
63+ , renderAliases
6264 , Aliased (As)
6365 , renderAliasedAs
6466 , AliasesOf
6567 , Has
6668 , HasUnique
69+ , HasAll
6770 , IsLabel (..)
6871 , IsQualified (..)
6972 -- * Type Families
@@ -79,6 +82,7 @@ module Squeal.PostgreSQL.Schema
7982 , PGFloating
8083 , PGTypeOf
8184 , SameTypes
85+ , SamePGType
8286 , AllNotNull
8387 , NotAllNull
8488 , NullifyType
@@ -98,16 +102,16 @@ module Squeal.PostgreSQL.Schema
98102
99103import Control.DeepSeq
100104import Data.ByteString
101−import Data.Monoid
105+import Data.Monoid hiding (All)
102106import Data.String
103107import Data.Word
104108import Data.Type.Bool
105−import Generics.SOP (AllZip)
106−import GHC.Generics (Generic)
107109import GHC.Exts
108110import GHC.OverloadedLabels
109111import GHC.TypeLits
110112
113+import qualified GHC.Generics as GHC
114+import qualified Generics.SOP as SOP
111115import qualified Generics.SOP.Type.Metadata as Type
112116
113117import Squeal.PostgreSQL.Render
@@ -355,7 +359,7 @@ instance {-# OVERLAPPABLE #-}
355359-- >>> #foobar :: Alias "foobar"
356360-- Alias
357361data Alias (alias :: Symbol) = Alias
358− deriving (Eq,Generic,Ord,Show,NFData)
362+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
359363instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
360364 fromLabel = Alias
361365
@@ -364,6 +368,14 @@ instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
364368renderAlias :: KnownSymbol alias => Alias alias -> ByteString
365369renderAlias = doubleQuoted . fromString . symbolVal
366370
371+-- | >>> import Generics.SOP (NP(..))
372+-- >>> renderAliases (#jimbob :* #kandi :* Nil)
373+-- ["\"jimbob\"","\"kandi\""]
374+renderAliases
375+ :: SOP.All KnownSymbol aliases => SOP.NP Alias aliases -> [ByteString]
376+renderAliases = SOP.hcollapse
377+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderAlias)
378+
367379-- | The `As` operator is used to name an expression. `As` is like a demoted
368380-- version of `:::`.
369381--
@@ -411,6 +423,18 @@ instance {-# OVERLAPPING #-} KnownSymbol alias
411423instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
412424 => Has alias (field' ': fields) field
413425
426+class
427+ ( SOP.All KnownSymbol aliases
428+ ) => HasAll
429+ (aliases :: [Symbol])
430+ (fields :: [(Symbol,kind)])
431+ (subfields :: [(Symbol,kind)])
432+ | aliases fields -> subfields where
433+instance {-# OVERLAPPING #-} HasAll '[] fields '[]
434+instance {-# OVERLAPPABLE #-}
435+ (Has alias fields field, HasAll aliases fields subfields)
436+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
437+
414438-- | Analagous to `IsLabel`, the constraint
415439-- `IsQualified` defines `!` for a column alias qualified
416440-- by a table alias.
@@ -456,6 +480,12 @@ type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)
456480 SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)
457481 = (ty0 ~ ty1, SameTypes columns0 columns1)
458482
483+class SamePGType
484+ (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where
485+instance ty0 ~ ty1 => SamePGType
486+ (alias0 ::: def0 :=> nullity0 ty0)
487+ (alias1 ::: def1 :=> nullity1 ty1)
488+
459489-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
460490type family AllNotNull (columns :: ColumnsType) :: Constraint where
461491 AllNotNull '[] = ()
@@ -506,12 +536,12 @@ type family Drop alias xs where
506536 Drop alias ((alias ::: x) ': xs) = xs
507537 Drop alias (x ': xs) = x ': Drop alias xs
508538
509−-- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@
539+-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
510540-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`
511541-- and `Squeal.PostgreSQL.Definition.alterColumn`.
512−type family Alter alias xs x where
513− Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
514− Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
542+type family Alter alias x xs where
543+ Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
544+ Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
515545
516546-- type family AddConstraint constraint ty where
517547-- AddConstraint constraint (constraints :=> ty)
@@ -548,11 +578,11 @@ type family SameFields
548578 SameFields
549579 ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
550580 columns
551− = AllZip SameField fields columns
581+ = SOP.AllZip SameField fields columns
552582 SameFields
553583 ('Type.Newtype _module _datatype ('Type.Record _constructor fields))
554584 columns
555− = AllZip SameField fields columns
585+ = SOP.AllZip SameField fields columns
556586
557587-- | Check if a `TableConstraint` involves a column
558588type family ConstraintInvolves column constraint where