From 8ca416a315de17943eba44676c2ab1b2ee84718d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 8 Apr 2018 21:53:26 -0700 Subject: [PATCH 01/92] 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` --- README.md | 6 +- squeal-postgresql/exe/Example.hs | 6 +- squeal-postgresql/src/Squeal/PostgreSQL.hs | 6 +- .../src/Squeal/PostgreSQL/Definition.hs | 222 ++++++++++-------- .../src/Squeal/PostgreSQL/Migration.hs | 8 +- .../src/Squeal/PostgreSQL/Schema.hs | 50 +++- 6 files changed, 177 insertions(+), 121 deletions(-) diff --git a/README.md b/README.md index 3b8e43b4..a187f344 100644 --- a/README.md +++ b/README.md @@ -128,13 +128,13 @@ let createTable #users ( serial `As` #id :* (text & notNull) `As` #name :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>> + ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* text `As` #email :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_emails :* - foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) + ( primaryKey (#id :* Nil) `As` #pk_emails :* + foreignKey (#user_id :* Nil) #users (#id :* Nil) OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) :} ``` diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index e9a99b5c..2064491d 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -47,14 +47,14 @@ setup = ( serial `As` #id :* (text & notNull) `As` #name :* (vararray int2 & notNull) `As` #vec :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) + ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* text `As` #email :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_emails :* - foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) + ( primaryKey (#id :* Nil) `As` #pk_emails :* + foreignKey (#user_id :* Nil) #users (#id :* Nil) OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) teardown :: Definition Schema '[] diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 1084e689..4fdf8fe4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -67,13 +67,13 @@ -- createTable #users -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>> +-- ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* -- text `As` #email :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_emails :* --- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) +-- ( primaryKey (#id :* Nil) `As` #pk_emails :* +-- foreignKey (#user_id :* Nil) #users (#id :* Nil) -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) -- :} -- diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index ef7ab601..793a4f91 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -37,12 +37,10 @@ module Squeal.PostgreSQL.Definition , createTable , createTableIfNotExists , TableConstraintExpression (..) - , Column (..) , check , unique , primaryKey , foreignKey - , ForeignKeyed , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade) , renderOnDeleteClause , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade) @@ -115,13 +113,14 @@ createTable :: ( KnownSymbol table , columns ~ (col ': cols) , SOP.SListI columns - , SOP.SListI constraints ) + , SOP.SListI constraints + , schema1 ~ Create table (constraints :=> columns) schema0 ) => Alias table -- ^ the name of the table to add -> NP (Aliased TypeExpression) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema columns)) constraints + -> NP (Aliased (TableConstraintExpression schema1 table)) constraints -- ^ constraints that must hold for the table - -> Definition schema (Create table (constraints :=> columns) schema) + -> Definition schema0 schema1 createTable table columns constraints = UnsafeDefinition $ "CREATE TABLE" <+> renderCreation table columns constraints @@ -144,7 +143,7 @@ createTableIfNotExists => Alias table -- ^ the name of the table to add -> NP (Aliased TypeExpression) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema columns)) constraints + -> NP (Aliased (TableConstraintExpression schema table)) constraints -- ^ constraints that must hold for the table -> Definition schema schema createTableIfNotExists table columns constraints = UnsafeDefinition $ @@ -159,7 +158,7 @@ renderCreation => Alias table -- ^ the name of the table to add -> NP (Aliased TypeExpression) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema columns)) constraints + -> NP (Aliased (TableConstraintExpression schema table)) constraints -- ^ constraints that must hold for the table -> ByteString renderCreation table columns constraints = renderAlias table @@ -194,43 +193,41 @@ renderCreation table columns constraints = renderAlias table -- even if the value came from the default value definition. newtype TableConstraintExpression (schema :: TablesType) - (columns :: ColumnsType) + (table :: Symbol) (tableConstraint :: TableConstraint) = UnsafeTableConstraintExpression { renderTableConstraintExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) --- | @Column columns column@ is a witness that `column` is in `columns`. -data Column - (columns :: ColumnsType) - (column :: (Symbol,ColumnType)) - where - Column - :: Has column columns ty - => Alias column - -> Column columns (column ::: ty) - --- | Render a `Column`. -renderColumn :: Column columns column -> ByteString -renderColumn (Column column) = renderAlias column - -- | 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. -- -- >>> :{ --- renderDefinition $ --- createTable #tab +-- type Schema = '[ +-- "tab" ::: '[ "inequality" ::: 'Check '["a","b"]] :=> '[ +-- "a" ::: 'NoDef :=> 'NotNull 'PGint4, +-- "b" ::: 'NoDef :=> 'NotNull 'PGint4 +-- ]] +-- :} +-- +-- >>> :{ +-- let +-- definition :: Definition '[] Schema +-- definition = createTable #tab -- ( (int & notNull) `As` #a :* -- (int & notNull) `As` #b :* Nil ) --- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) +-- ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) -- :} +-- +-- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));" check - :: NP (Column columns) subcolumns - -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[] - -- ^ condition to check - -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns)) + :: ( Has alias schema table + , HasAll aliases (TableToColumns table) subcolumns ) + => NP Alias aliases + -> (forall tab. Condition '[tab ::: ColumnsToRelation subcolumns] 'Ungrouped '[]) + -> TableConstraintExpression schema alias ('Check aliases) check _cols condition = UnsafeTableConstraintExpression $ "CHECK" <+> parenthesized (renderExpression condition) @@ -238,40 +235,62 @@ check _cols condition = UnsafeTableConstraintExpression $ -- or a group of columns, is unique among all the rows in the table. -- -- >>> :{ --- renderDefinition $ --- createTable #tab +-- type Schema = '[ +-- "tab" ::: '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[ +-- "a" ::: 'NoDef :=> 'Null 'PGint4, +-- "b" ::: 'NoDef :=> 'Null 'PGint4 +-- ]] +-- :} +-- +-- >>> :{ +-- let +-- definition :: Definition '[] Schema +-- definition = createTable #tab -- ( int `As` #a :* -- int `As` #b :* Nil ) --- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil ) +-- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) -- :} +-- +-- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" unique - :: SOP.SListI subcolumns - => NP (Column columns) subcolumns - -- ^ unique column or group of columns - -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns)) + :: ( Has alias schema table + , HasAll aliases (TableToColumns table) subcolumns ) + => NP Alias aliases + -> TableConstraintExpression schema alias ('Unique aliases) unique columns = UnsafeTableConstraintExpression $ - "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns) + "UNIQUE" <+> parenthesized (commaSeparated (renderAliases 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. -- -- >>> :{ --- renderDefinition $ --- createTable #tab +-- type Schema = '[ +-- "tab" ::: '[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[ +-- "id" ::: 'Def :=> 'NotNull 'PGint4, +-- "name" ::: 'NoDef :=> 'NotNull 'PGtext +-- ]] +-- :} +-- +-- >>> :{ +-- let +-- definition :: Definition '[] Schema +-- definition = createTable #tab -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil ) +-- ( primaryKey (#id :* Nil) `As` #pk_id :* Nil ) -- :} +-- +-- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));" primaryKey - :: (SOP.SListI subcolumns, AllNotNull subcolumns) - => NP (Column columns) subcolumns - -- ^ identifying column or group of columns - -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns)) + :: ( Has alias schema table + , HasAll aliases (TableToColumns table) subcolumns ) + => NP Alias aliases + -> TableConstraintExpression schema alias ('PrimaryKey aliases) primaryKey columns = UnsafeTableConstraintExpression $ - "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns) + "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns)) -- | A `foreignKey` specifies that the values in a column -- (or a group of columns) must match the values appearing in some row of @@ -303,46 +322,41 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- createTable #users -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>> +-- ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* -- text `As` #email :* Nil ) --- ( primaryKey (Column #id :* Nil) `As` #pk_emails :* --- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) +-- ( primaryKey (#id :* Nil) `As` #pk_emails :* +-- foreignKey (#user_id :* Nil) #users (#id :* Nil) -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) -- in renderDefinition 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, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" foreignKey - :: ForeignKeyed schema table reftable subcolumns refsubcolumns - => NP (Column columns) subcolumns + :: ( Has child schema table + , Has parent schema reftable + , HasAll columns (TableToColumns table) tys + , HasAll refcolumns (TableToColumns reftable) reftys + , SOP.AllZip SamePGType tys reftys ) + => NP Alias columns -- ^ column or columns in the table - -> Alias table + -> Alias parent -- ^ reference table - -> NP (Column (TableToColumns reftable)) refsubcolumns + -> 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 schema columns - ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns)) -foreignKey columns reftable refcolumns onDelete onUpdate = - UnsafeTableConstraintExpression $ - "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns) - <+> "REFERENCES" <+> renderAlias reftable - <+> parenthesized (renderCommaSeparated renderColumn refcolumns) - <+> renderOnDeleteClause onDelete - <+> renderOnUpdateClause onUpdate - --- | A type synonym for constraints on a table with a foreign key. -type ForeignKeyed schema table reftable subcolumns refsubcolumns - = ( Has table schema reftable - , SameTypes subcolumns refsubcolumns - , AllNotNull subcolumns - , SOP.SListI subcolumns - , SOP.SListI refsubcolumns ) + -> TableConstraintExpression schema child + ('ForeignKey columns parent refcolumns) +foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ + "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys)) + <+> "REFERENCES" <+> renderAlias parent + <+> parenthesized (commaSeparated (renderAliases refs)) + <+> renderOnDeleteClause ondel + <+> renderOnUpdateClause onupd -- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. data OnDeleteClause @@ -403,10 +417,10 @@ ALTER statements -- | `alterTable` changes the definition of a table from the schema. alterTable - :: Has tab schema table0 - => Alias tab -- ^ table to alter - -> AlterTable schema table0 table1 -- ^ alteration to perform - -> Definition schema (Alter tab schema table1) + :: KnownSymbol alias + => Alias alias -- ^ table to alter + -> AlterTable alias table schema -- ^ alteration to perform + -> Definition schema (Alter alias table schema) alterTable table alteration = UnsafeDefinition $ "ALTER TABLE" <+> renderAlias table @@ -429,9 +443,9 @@ alterTableRename table0 table1 = UnsafeDefinition $ -- | An `AlterTable` describes the alteration to perform on the columns -- of a table. newtype AlterTable - (schema :: TablesType) - (table0 :: TableType) - (table1 :: TableType) = + (alias :: Symbol) + (table :: TableType) + (schema :: TablesType) = UnsafeAlterTable {renderAlterTable :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -442,17 +456,19 @@ newtype AlterTable -- definition :: Definition -- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] -- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0))) +-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0))) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));" addConstraint - :: KnownSymbol alias + :: ( KnownSymbol alias + , Has tab schema table0 + , table0 ~ (constraints :=> columns) + , table1 ~ (Create alias constraint constraints :=> columns) ) => Alias alias - -> TableConstraintExpression schema columns constraint + -> TableConstraintExpression schema tab constraint -- ^ constraint to add - -> AlterTable schema (constraints :=> columns) - (Create alias constraint constraints :=> columns) + -> AlterTable tab table1 schema addConstraint alias constraint = UnsafeAlterTable $ "ADD" <+> "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint @@ -469,12 +485,13 @@ addConstraint alias constraint = UnsafeAlterTable $ -- :} -- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";" dropConstraint - :: KnownSymbol constraint + :: ( KnownSymbol constraint + , Has tab schema table0 + , table0 ~ (constraints :=> columns) + , table1 ~ (Drop constraint constraints :=> columns) ) => Alias constraint -- ^ constraint to drop - -> AlterTable schema - (constraints :=> columns) - (Drop constraint constraints :=> columns) + -> AlterTable tab table1 schema dropConstraint constraint = UnsafeAlterTable $ "DROP" <+> "CONSTRAINT" <+> renderAlias constraint @@ -507,11 +524,13 @@ class AddColumn ty where -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;" addColumn - :: KnownSymbol column + :: ( KnownSymbol column + , Has tab schema table0 + , table0 ~ (constraints :=> columns) + , table1 ~ (constraints :=> Create column ty columns) ) => Alias column -- ^ column to add -> TypeExpression ty -- ^ type of the new column - -> AlterTable schema (constraints :=> columns) - (constraints :=> Create column ty columns) + -> AlterTable tab table1 schema addColumn column ty = UnsafeAlterTable $ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) @@ -534,11 +553,12 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- :} -- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";" dropColumn - :: KnownSymbol column + :: ( KnownSymbol column + , Has tab schema table0 + , table0 ~ (constraints :=> columns) + , table1 ~ (constraints :=> Drop column columns) ) => Alias column -- ^ column to remove - -> AlterTable schema - (constraints :=> columns) - (DropIfConstraintsInvolve column constraints :=> Drop column columns) + -> AlterTable tab table1 schema dropColumn column = UnsafeAlterTable $ "DROP COLUMN" <+> renderAlias column @@ -554,21 +574,27 @@ dropColumn column = UnsafeAlterTable $ -- :} -- "ALTER TABLE \"tab\" RENAME COLUMN \"foo\" TO \"bar\";" renameColumn - :: (KnownSymbol column0, KnownSymbol column1) + :: ( KnownSymbol column0 + , KnownSymbol column1 + , Has tab schema table0 + , table0 ~ (constraints :=> columns) + , table1 ~ (constraints :=> Rename column0 column1 columns) ) => Alias column0 -- ^ column to rename -> Alias column1 -- ^ what to rename the column - -> AlterTable schema (constraints :=> columns) - (constraints :=> Rename column0 column1 columns) + -> AlterTable tab table1 schema renameColumn column0 column1 = UnsafeAlterTable $ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1 -- | An `alterColumn` alters a single column. alterColumn - :: (KnownSymbol column, Has column columns ty0) + :: ( KnownSymbol column + , Has tab schema table0 + , table0 ~ (constraints :=> columns) + , Has column columns ty0 + , tables1 ~ (constraints :=> Alter column ty1 columns)) => Alias column -- ^ column to alter -> AlterColumn ty0 ty1 -- ^ alteration to perform - -> AlterTable schema (constraints :=> columns) - (constraints :=> Alter column columns ty1) + -> AlterTable tab table1 schema alterColumn column alteration = UnsafeAlterTable $ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index b3c5b598..28cde880 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -38,7 +38,7 @@ let createTable #users ( serial `As` #id :* (text & notNull) `As` #name :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) + ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) , down = void . define $ dropTable #users } :} @@ -54,8 +54,8 @@ let ( serial `As` #id :* (int & notNull) `As` #user_id :* text `As` #email :* Nil ) - ( primaryKey (Column #id :* Nil) `As` #pk_emails :* - foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil) + ( primaryKey (#id :* Nil) `As` #pk_emails :* + foreignKey (#user_id :* Nil) #users (#id :* Nil) OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) , down = void . define $ dropTable #emails } @@ -290,7 +290,7 @@ createMigrations = ( (text & notNull) `As` #name :* (timestampWithTimeZone & notNull & default_ currentTimestamp) `As` #executed_at :* Nil ) - ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil ) + ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil ) -- | Inserts a `Migration` into the `MigrationsTable` insertMigration diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index c3ab8286..82fbd3e5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -31,6 +31,7 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. , TypeInType , TypeOperators , UndecidableInstances + , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Schema @@ -59,11 +60,13 @@ module Squeal.PostgreSQL.Schema , (:::) , Alias (Alias) , renderAlias + , renderAliases , Aliased (As) , renderAliasedAs , AliasesOf , Has , HasUnique + , HasAll , IsLabel (..) , IsQualified (..) -- * Type Families @@ -79,6 +82,7 @@ module Squeal.PostgreSQL.Schema , PGFloating , PGTypeOf , SameTypes + , SamePGType , AllNotNull , NotAllNull , NullifyType @@ -98,16 +102,16 @@ module Squeal.PostgreSQL.Schema import Control.DeepSeq import Data.ByteString -import Data.Monoid +import Data.Monoid hiding (All) import Data.String import Data.Word import Data.Type.Bool -import Generics.SOP (AllZip) -import GHC.Generics (Generic) import GHC.Exts import GHC.OverloadedLabels import GHC.TypeLits +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP import qualified Generics.SOP.Type.Metadata as Type import Squeal.PostgreSQL.Render @@ -355,7 +359,7 @@ instance {-# OVERLAPPABLE #-} -- >>> #foobar :: Alias "foobar" -- Alias data Alias (alias :: Symbol) = Alias - deriving (Eq,Generic,Ord,Show,NFData) + deriving (Eq,GHC.Generic,Ord,Show,NFData) instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where fromLabel = Alias @@ -364,6 +368,14 @@ instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where renderAlias :: KnownSymbol alias => Alias alias -> ByteString renderAlias = doubleQuoted . fromString . symbolVal +-- | >>> import Generics.SOP (NP(..)) +-- >>> renderAliases (#jimbob :* #kandi :* Nil) +-- ["\"jimbob\"","\"kandi\""] +renderAliases + :: SOP.All KnownSymbol aliases => SOP.NP Alias aliases -> [ByteString] +renderAliases = SOP.hcollapse + . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderAlias) + -- | The `As` operator is used to name an expression. `As` is like a demoted -- version of `:::`. -- @@ -411,6 +423,18 @@ instance {-# OVERLAPPING #-} KnownSymbol alias instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field) => Has alias (field' ': fields) field +class + ( SOP.All KnownSymbol aliases + ) => HasAll + (aliases :: [Symbol]) + (fields :: [(Symbol,kind)]) + (subfields :: [(Symbol,kind)]) + | aliases fields -> subfields where +instance {-# OVERLAPPING #-} HasAll '[] fields '[] +instance {-# OVERLAPPABLE #-} + (Has alias fields field, HasAll aliases fields subfields) + => HasAll (alias ': aliases) fields (alias ::: field ': subfields) + -- | Analagous to `IsLabel`, the constraint -- `IsQualified` defines `!` for a column alias qualified -- by a table alias. @@ -456,6 +480,12 @@ type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType) SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1) = (ty0 ~ ty1, SameTypes columns0 columns1) +class SamePGType + (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where +instance ty0 ~ ty1 => SamePGType + (alias0 ::: def0 :=> nullity0 ty0) + (alias1 ::: def1 :=> nullity1 ty1) + -- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. type family AllNotNull (columns :: ColumnsType) :: Constraint where AllNotNull '[] = () @@ -506,12 +536,12 @@ type family Drop alias xs where Drop alias ((alias ::: x) ': xs) = xs Drop alias (x ': xs) = x ': Drop alias xs --- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@ +-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@ -- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable` -- and `Squeal.PostgreSQL.Definition.alterColumn`. -type family Alter alias xs x where - Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs - Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1 +type family Alter alias x xs where + Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs + Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs -- type family AddConstraint constraint ty where -- AddConstraint constraint (constraints :=> ty) @@ -548,11 +578,11 @@ type family SameFields SameFields ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields]) columns - = AllZip SameField fields columns + = SOP.AllZip SameField fields columns SameFields ('Type.Newtype _module _datatype ('Type.Record _constructor fields)) columns - = AllZip SameField fields columns + = SOP.AllZip SameField fields columns -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where From 8d2df16db229374a3eb6980b7a05085f3d850779 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 8 Apr 2018 22:00:30 -0700 Subject: [PATCH 02/92] omg that looks so nice --- README.md | 6 +++--- squeal-postgresql/exe/Example.hs | 6 +++--- squeal-postgresql/src/Squeal/PostgreSQL.hs | 6 +++--- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 8 ++++---- squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs | 6 +++--- squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 2 ++ 6 files changed, 18 insertions(+), 16 deletions(-) diff --git a/README.md b/README.md index a187f344..8bfd94c4 100644 --- a/README.md +++ b/README.md @@ -128,13 +128,13 @@ let createTable #users ( serial `As` #id :* (text & notNull) `As` #name :* Nil ) - ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> + ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* text `As` #email :* Nil ) - ( primaryKey (#id :* Nil) `As` #pk_emails :* - foreignKey (#user_id :* Nil) #users (#id :* Nil) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) :} ``` diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index 2064491d..c11f18e3 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -47,14 +47,14 @@ setup = ( serial `As` #id :* (text & notNull) `As` #name :* (vararray int2 & notNull) `As` #vec :* Nil ) - ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* text `As` #email :* Nil ) - ( primaryKey (#id :* Nil) `As` #pk_emails :* - foreignKey (#user_id :* Nil) #users (#id :* Nil) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) teardown :: Definition Schema '[] diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 4fdf8fe4..8ac91045 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -67,13 +67,13 @@ -- createTable #users -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> +-- ( primaryKey #id `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* -- text `As` #email :* Nil ) --- ( primaryKey (#id :* Nil) `As` #pk_emails :* --- foreignKey (#user_id :* Nil) #users (#id :* Nil) +-- ( primaryKey #id `As` #pk_emails :* +-- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) -- :} -- diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 793a4f91..067f3750 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -279,7 +279,7 @@ unique columns = UnsafeTableConstraintExpression $ -- definition = createTable #tab -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (#id :* Nil) `As` #pk_id :* Nil ) +-- ( primaryKey #id `As` #pk_id :* Nil ) -- :} -- -- >>> renderDefinition definition @@ -322,13 +322,13 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- createTable #users -- ( serial `As` #id :* -- (text & notNull) `As` #name :* Nil ) --- ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) >>> +-- ( primaryKey #id `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* -- text `As` #email :* Nil ) --- ( primaryKey (#id :* Nil) `As` #pk_emails :* --- foreignKey (#user_id :* Nil) #users (#id :* Nil) +-- ( primaryKey #id `As` #pk_emails :* +-- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) -- in renderDefinition setup -- :} diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 28cde880..a08291f0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -38,7 +38,7 @@ let createTable #users ( serial `As` #id :* (text & notNull) `As` #name :* Nil ) - ( primaryKey (#id :* Nil) `As` #pk_users :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) , down = void . define $ dropTable #users } :} @@ -54,8 +54,8 @@ let ( serial `As` #id :* (int & notNull) `As` #user_id :* text `As` #email :* Nil ) - ( primaryKey (#id :* Nil) `As` #pk_emails :* - foreignKey (#user_id :* Nil) #users (#id :* Nil) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) , down = void . define $ dropTable #emails } diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 82fbd3e5..100774de 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -362,6 +362,8 @@ data Alias (alias :: Symbol) = Alias deriving (Eq,GHC.Generic,Ord,Show,NFData) instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where fromLabel = Alias +instance aliases ~ '[alias] => IsLabel alias (SOP.NP Alias aliases) where + fromLabel = fromLabel SOP.:* SOP.Nil -- | >>> renderAlias #jimbob -- "\"jimbob\"" From 8945616c759328be8336c218d6aad6038ffdc934 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 8 Apr 2018 22:55:35 -0700 Subject: [PATCH 03/92] type safe foreign and primary keys * check primary keys are all not null * check foreign keys reference all not null and either primary keys or unique columns --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 10 +++++++--- squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 8 ++++++++ 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 067f3750..a19e81c1 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -286,7 +286,8 @@ unique columns = UnsafeTableConstraintExpression $ -- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));" primaryKey :: ( Has alias schema table - , HasAll aliases (TableToColumns table) subcolumns ) + , HasAll aliases (TableToColumns table) subcolumns + , AllNotNull subcolumns ) => NP Alias aliases -> TableConstraintExpression schema alias ('PrimaryKey aliases) primaryKey columns = UnsafeTableConstraintExpression $ @@ -337,8 +338,11 @@ foreignKey :: ( Has child schema table , Has parent schema reftable , HasAll columns (TableToColumns table) tys - , HasAll refcolumns (TableToColumns reftable) reftys - , SOP.AllZip SamePGType tys reftys ) + , reftable ~ (constraints :=> cols) + , HasAll refcolumns cols reftys + , SOP.AllZip SamePGType tys reftys + , AllNotNull reftys + , Uniquely refcolumns constraints ) => NP Alias columns -- ^ column or columns in the table -> Alias parent diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 100774de..60c8019f 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -56,6 +56,7 @@ module Squeal.PostgreSQL.Schema , TableConstraint (..) , TableConstraints , NilTableConstraints + , Uniquely -- * Aliases , (:::) , Alias (Alias) @@ -248,6 +249,13 @@ type TableConstraints = [(Symbol,TableConstraint)] type family NilTableConstraints :: TableConstraints where NilTableConstraints = '[] +type family Uniquely + (keys :: [Symbol]) + (constraints :: TableConstraints) :: Constraint where + Uniquely keys (uq ::: 'Unique keys ': constraints) = () + Uniquely keys (uq ::: 'PrimaryKey keys ': constraints) = () + Uniquely keys (_ ': constraints) = Uniquely keys constraints + -- | `TableType` encodes a row of constraints on a table as well as the types -- of its columns. -- From 91a5465dc017d1996092485151ded2368753f5cc Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 8 Apr 2018 23:12:48 -0700 Subject: [PATCH 04/92] test self references --- .../src/Squeal/PostgreSQL/Definition.hs | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index a19e81c1..110b9c3f 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -334,6 +334,37 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- in renderDefinition 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, 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" ::: +-- '[ "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 '[] Schema +-- setup = +-- createTable #employees +-- ( serial `As` #id :* +-- (text & notNull) `As` #name :* +-- integer `As` #employer_id :* Nil ) +-- ( primaryKey #id `As` #employees_pk :* +-- foreignKey #employer_id #employees #id +-- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) +-- in renderDefinition setup +-- :} +-- "CREATE TABLE \"employees\" (\"id\" serial, \"name\" text NOT NULL, \"employer_id\" integer, CONSTRAINT \"employees_pk\" PRIMARY KEY (\"id\"), CONSTRAINT \"employees_employer_fk\" FOREIGN KEY (\"employer_id\") REFERENCES \"employees\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" +-- foreignKey :: ( Has child schema table , Has parent schema reftable From 7f55fa5d634e441cc5851f56c9c801d3010c9820 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 9 Apr 2018 08:53:25 -0700 Subject: [PATCH 05/92] makes the docs prettier with `ForeignKeyed` --- .../src/Squeal/PostgreSQL/Definition.hs | 29 ++++++++++++++----- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 110b9c3f..73ffcae0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -41,6 +41,7 @@ module Squeal.PostgreSQL.Definition , unique , primaryKey , foreignKey + , ForeignKeyed , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade) , renderOnDeleteClause , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade) @@ -366,14 +367,11 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- "CREATE TABLE \"employees\" (\"id\" serial, \"name\" text NOT NULL, \"employer_id\" integer, CONSTRAINT \"employees_pk\" PRIMARY KEY (\"id\"), CONSTRAINT \"employees_employer_fk\" FOREIGN KEY (\"employer_id\") REFERENCES \"employees\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" -- foreignKey - :: ( Has child schema table - , Has parent schema reftable - , HasAll columns (TableToColumns table) tys - , reftable ~ (constraints :=> cols) - , HasAll refcolumns cols reftys - , SOP.AllZip SamePGType tys reftys - , AllNotNull reftys - , Uniquely refcolumns constraints ) + :: (ForeignKeyed schema child parent + table reftable + columns refcolumns + constraints cols + reftys tys ) => NP Alias columns -- ^ column or columns in the table -> Alias parent @@ -393,6 +391,21 @@ foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ <+> renderOnDeleteClause ondel <+> renderOnUpdateClause onupd +type ForeignKeyed schema + child parent + table reftable + columns refcolumns + constraints cols + reftys tys = + ( Has child schema table + , Has parent schema reftable + , HasAll columns (TableToColumns table) tys + , reftable ~ (constraints :=> cols) + , HasAll refcolumns cols reftys + , SOP.AllZip SamePGType tys reftys + , AllNotNull reftys + , Uniquely refcolumns constraints ) + -- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. data OnDeleteClause = OnDeleteNoAction From b9103f40cc9e5b29cf20ec06421181cf4b1a629a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 9 Apr 2018 09:17:32 -0700 Subject: [PATCH 06/92] andThen --- squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs index 6e489523..9bb23ccf 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs @@ -217,6 +217,7 @@ class IndexedMonadTransPQ pq where :: Monad m => pq schema0 schema1 m (pq schema1 schema2 m y) -> pq schema0 schema2 m y + pqJoin pq = pq & pqBind id -- | indexed analog of `=<<` pqBind @@ -231,6 +232,15 @@ class IndexedMonadTransPQ pq where => pq schema1 schema2 m y -> pq schema0 schema1 m x -> pq schema0 schema2 m y + pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) + + -- | indexed analog of `<=<` + pqAndThen + :: Monad m + => (y -> pq schema1 schema2 m z) + -> (x -> pq schema0 schema1 m y) + -> x -> pq schema0 schema2 m z + pqAndThen g f x = pqBind g (f x) -- | Safely embed a computation in a larger schema. pqEmbed @@ -253,14 +263,10 @@ instance IndexedMonadTransPQ PQ where K x' <- x (K (unK conn)) return $ K (f' x') - pqJoin pq = pq & pqBind id - pqBind f (PQ x) = PQ $ \ conn -> do K x' <- x conn unPQ (f x') (K (unK conn)) - pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) - pqEmbed (PQ pq) = PQ $ \ (K conn) -> do K x <- pq (K conn) return $ K x From 0120fc6b19aaf37b3d02c1704b9e2821090cfd21 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 9 Apr 2018 10:38:47 -0700 Subject: [PATCH 07/92] small change --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 1 - squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 10 ++++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 73ffcae0..4721159e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -403,7 +403,6 @@ type ForeignKeyed schema , reftable ~ (constraints :=> cols) , HasAll refcolumns cols reftys , SOP.AllZip SamePGType tys reftys - , AllNotNull reftys , Uniquely refcolumns constraints ) -- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 60c8019f..5f7dbff3 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -249,12 +249,14 @@ type TableConstraints = [(Symbol,TableConstraint)] type family NilTableConstraints :: TableConstraints where NilTableConstraints = '[] +-- | A `ForeignKey` must reference columns that either are +-- a `PrimaryKey` or form a `Unique` constraint. type family Uniquely - (keys :: [Symbol]) + (key :: [Symbol]) (constraints :: TableConstraints) :: Constraint where - Uniquely keys (uq ::: 'Unique keys ': constraints) = () - Uniquely keys (uq ::: 'PrimaryKey keys ': constraints) = () - Uniquely keys (_ ': constraints) = Uniquely keys constraints + Uniquely key (uq ::: 'Unique key ': constraints) = () + Uniquely key (pk ::: 'PrimaryKey key ': constraints) = () + Uniquely key (_ ': constraints) = Uniquely key constraints -- | `TableType` encodes a row of constraints on a table as well as the types -- of its columns. From db940a037d5b92277d2584e3f9883d69210a3407 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 9 Apr 2018 11:08:18 -0700 Subject: [PATCH 08/92] views --- .../src/Squeal/PostgreSQL/Definition.hs | 36 +++++++++---------- .../src/Squeal/PostgreSQL/Expression.hs | 4 +-- .../src/Squeal/PostgreSQL/Manipulation.hs | 24 ++++++------- .../src/Squeal/PostgreSQL/Migration.hs | 14 ++++---- squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs | 4 +-- .../src/Squeal/PostgreSQL/Pool.hs | 2 +- .../src/Squeal/PostgreSQL/Query.hs | 4 +-- .../src/Squeal/PostgreSQL/Schema.hs | 32 +++++++++++++++++ 8 files changed, 76 insertions(+), 44 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 4721159e..259db598 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -88,8 +88,8 @@ statements -- database, like a `createTable`, `dropTable`, or `alterTable` command. -- `Definition`s may be composed using the `>>>` operator. newtype Definition - (schema0 :: TablesType) - (schema1 :: TablesType) + (schema0 :: SchemaType) + (schema1 :: SchemaType) = UnsafeDefinition { renderDefinition :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -115,7 +115,7 @@ createTable , columns ~ (col ': cols) , SOP.SListI columns , SOP.SListI constraints - , schema1 ~ Create table (constraints :=> columns) schema0 ) + , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 ) => Alias table -- ^ the name of the table to add -> NP (Aliased TypeExpression) columns -- ^ the names and datatype of each column @@ -138,7 +138,7 @@ createTable table columns constraints = UnsafeDefinition $ -- :} -- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int, \"b\" real);" createTableIfNotExists - :: ( Has table schema (constraints :=> columns) + :: ( Has table (TablesOf schema) (constraints :=> columns) , SOP.SListI columns , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add @@ -193,7 +193,7 @@ renderCreation table columns constraints = renderAlias table -- violate a constraint, an error is raised. This applies -- even if the value came from the default value definition. newtype TableConstraintExpression - (schema :: TablesType) + (schema :: SchemaType) (table :: Symbol) (tableConstraint :: TableConstraint) = UnsafeTableConstraintExpression @@ -224,7 +224,7 @@ newtype TableConstraintExpression -- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));" check - :: ( Has alias schema table + :: ( Has alias (TablesOf schema) table , HasAll aliases (TableToColumns table) subcolumns ) => NP Alias aliases -> (forall tab. Condition '[tab ::: ColumnsToRelation subcolumns] 'Ungrouped '[]) @@ -255,7 +255,7 @@ check _cols condition = UnsafeTableConstraintExpression $ -- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" unique - :: ( Has alias schema table + :: ( Has alias (TablesOf schema) table , HasAll aliases (TableToColumns table) subcolumns ) => NP Alias aliases -> TableConstraintExpression schema alias ('Unique aliases) @@ -286,7 +286,7 @@ unique columns = UnsafeTableConstraintExpression $ -- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));" primaryKey - :: ( Has alias schema table + :: ( Has alias (TablesOf schema) table , HasAll aliases (TableToColumns table) subcolumns , AllNotNull subcolumns ) => NP Alias aliases @@ -397,8 +397,8 @@ type ForeignKeyed schema columns refcolumns constraints cols reftys tys = - ( Has child schema table - , Has parent schema reftable + ( Has child (TablesOf schema) table + , Has parent (TablesOf schema) reftable , HasAll columns (TableToColumns table) tys , reftable ~ (constraints :=> cols) , HasAll refcolumns cols reftys @@ -467,7 +467,7 @@ alterTable :: KnownSymbol alias => Alias alias -- ^ table to alter -> AlterTable alias table schema -- ^ alteration to perform - -> Definition schema (Alter alias table schema) + -> Definition schema (Alter alias ('Table table) schema) alterTable table alteration = UnsafeDefinition $ "ALTER TABLE" <+> renderAlias table @@ -492,7 +492,7 @@ alterTableRename table0 table1 = UnsafeDefinition $ newtype AlterTable (alias :: Symbol) (table :: TableType) - (schema :: TablesType) = + (schema :: SchemaType) = UnsafeAlterTable {renderAlterTable :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -509,7 +509,7 @@ newtype AlterTable -- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));" addConstraint :: ( KnownSymbol alias - , Has tab schema table0 + , Has tab (TablesOf schema) table0 , table0 ~ (constraints :=> columns) , table1 ~ (Create alias constraint constraints :=> columns) ) => Alias alias @@ -533,7 +533,7 @@ addConstraint alias constraint = UnsafeAlterTable $ -- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";" dropConstraint :: ( KnownSymbol constraint - , Has tab schema table0 + , Has tab (TablesOf schema) table0 , table0 ~ (constraints :=> columns) , table1 ~ (Drop constraint constraints :=> columns) ) => Alias constraint @@ -572,7 +572,7 @@ class AddColumn ty where -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;" addColumn :: ( KnownSymbol column - , Has tab schema table0 + , Has tab (TablesOf schema) table0 , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Create column ty columns) ) => Alias column -- ^ column to add @@ -601,7 +601,7 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";" dropColumn :: ( KnownSymbol column - , Has tab schema table0 + , Has tab (TablesOf schema) table0 , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Drop column columns) ) => Alias column -- ^ column to remove @@ -623,7 +623,7 @@ dropColumn column = UnsafeAlterTable $ renameColumn :: ( KnownSymbol column0 , KnownSymbol column1 - , Has tab schema table0 + , Has tab (TablesOf schema) table0 , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Rename column0 column1 columns) ) => Alias column0 -- ^ column to rename @@ -635,7 +635,7 @@ renameColumn column0 column1 = UnsafeAlterTable $ -- | An `alterColumn` alters a single column. alterColumn :: ( KnownSymbol column - , Has tab schema table0 + , Has tab (TablesOf schema) table0 , table0 ~ (constraints :=> columns) , Has column columns ty0 , tables1 ~ (constraints :=> Alter column ty1 columns)) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index ba1c2ce6..485948b7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -1026,12 +1026,12 @@ tables -- | A `Table` from a table expression is a way -- to call a table reference by its alias. newtype Table - (schema :: TablesType) + (schema :: SchemaType) (columns :: RelationType) = UnsafeTable { renderTable :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) instance - ( Has alias schema table + ( Has alias (TablesOf schema) table , relation ~ ColumnsToRelation (TableToColumns table) ) => IsLabel alias (Table schema relation) where fromLabel = UnsafeTable $ renderAlias (Alias @alias) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index 4a2d0642..f1b9ebd0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -187,7 +187,7 @@ in renderManipulation manipulation "DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;" -} newtype Manipulation - (schema :: TablesType) + (schema :: SchemaType) (params :: [NullityType]) (columns :: RelationType) = UnsafeManipulation { renderManipulation :: ByteString } @@ -213,7 +213,7 @@ INSERT statements insertRows :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -243,7 +243,7 @@ insertRows tab row rows conflict returning = UnsafeManipulation $ insertRow :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -256,7 +256,7 @@ insertRow tab row = insertRows tab row [] -- | Insert multiple rows returning `Nil` and raising an error on conflicts. insertRows_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -268,7 +268,7 @@ insertRows_ tab row rows = -- | Insert a single row returning `Nil` and raising an error on conflicts. insertRow_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -279,7 +279,7 @@ insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil) insertQuery :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) @@ -296,7 +296,7 @@ insertQuery tab query conflict returning = UnsafeManipulation $ -- | Insert a `Query` returning `Nil` and raising an error on conflicts. insertQuery_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) @@ -401,7 +401,7 @@ UPDATE statements update :: ( SOP.SListI columns , SOP.SListI results - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to update -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns @@ -431,7 +431,7 @@ update tab columns wh returning = UnsafeManipulation $ -- | Update a row returning `Nil`. update_ :: ( SOP.SListI columns - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to update -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns @@ -448,7 +448,7 @@ DELETE statements -- | Delete rows of a table. deleteFrom :: ( SOP.SListI results - , Has tab schema table + , Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params @@ -462,7 +462,7 @@ deleteFrom tab wh returning = UnsafeManipulation $ -- | Delete rows returning `Nil`. deleteFrom_ - :: ( Has tab schema table + :: ( Has tab (TablesOf schema) table , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params @@ -493,7 +493,7 @@ with :: SOP.SListI commons => NP (Aliased (Manipulation schema params)) commons -- ^ common table expressions - -> Manipulation (Join (RelationsToTables commons) schema) params results + -> Manipulation (With commons schema) params results -> Manipulation schema params results with commons manipulation = UnsafeManipulation $ "WITH" <+> renderCommaSeparated renderCommon commons diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index a08291f0..c36489e2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -162,8 +162,8 @@ migrateUp :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io () migrateUp migration = define createMigrations @@ -218,8 +218,8 @@ migrateDown :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io () migrateDown migrations = define createMigrations @@ -283,7 +283,7 @@ type MigrationsTable = -- | Creates a `MigrationsTable` if it does not already exist. createMigrations - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" (TablesOf schema) MigrationsTable => Definition schema schema createMigrations = createTableIfNotExists #schema_migrations @@ -294,7 +294,7 @@ createMigrations = -- | Inserts a `Migration` into the `MigrationsTable` insertMigration - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" (TablesOf schema) MigrationsTable => Manipulation schema '[ 'NotNull 'PGtext] '[] insertMigration = insertRow_ #schema_migrations ( Set (param @1) `As` #name :* @@ -302,7 +302,7 @@ insertMigration = insertRow_ #schema_migrations -- | Deletes a `Migration` from the `MigrationsTable` deleteMigration - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" (TablesOf schema) MigrationsTable => Manipulation schema '[ 'NotNull 'PGtext ] '[] deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs index 9bb23ccf..9c17ef1c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs @@ -160,8 +160,8 @@ lowerConnection (K conn) = K conn -- | We keep track of the schema via an Atkey indexed state monad transformer, -- `PQ`. newtype PQ - (schema0 :: TablesType) - (schema1 :: TablesType) + (schema0 :: SchemaType) + (schema1 :: SchemaType) (m :: Type -> Type) (x :: Type) = PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) } diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs index 92104c97..7e685180 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs @@ -43,7 +43,7 @@ import Squeal.PostgreSQL.PQ import Squeal.PostgreSQL.Schema -- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@. -newtype PoolPQ (schema :: TablesType) m x = +newtype PoolPQ (schema :: SchemaType) m x = PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x } deriving Functor diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 8639d922..993b12f3 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -281,7 +281,7 @@ in renderQuery query "(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")" -} newtype Query - (schema :: TablesType) + (schema :: SchemaType) (params :: [NullityType]) (columns :: RelationType) = UnsafeQuery { renderQuery :: ByteString } @@ -443,7 +443,7 @@ Table Expressions -- to a table on disk, a so-called base table, but more complex expressions -- can be used to modify or combine base tables in various ways. data TableExpression - (schema :: TablesType) + (schema :: SchemaType) (params :: [NullityType]) (relations :: RelationsType) (grouping :: Grouping) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 5f7dbff3..01f9b646 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -99,6 +99,12 @@ module Squeal.PostgreSQL.Schema -- * Generics , SameField , SameFields + -- * Schema + , SchemumType (..) + , SchemaType + , TablesOf + , ViewsOf + , With ) where import Control.DeepSeq @@ -611,3 +617,29 @@ type family DropIfConstraintsInvolve column constraints where = If (ConstraintInvolves column constraint) (DropIfConstraintsInvolve column constraints) (alias ::: constraint ': DropIfConstraintsInvolve column constraints) + +data SchemumType + = Table TableType + | View RelationType + +type SchemaType = [(Symbol,SchemumType)] + +type family TablesOf (schema :: SchemaType) :: TablesType where + TablesOf '[] = '[] + TablesOf (alias ::: 'Table table ': schema) = + alias ::: table ': TablesOf schema + TablesOf (_ ': schema) = TablesOf schema + +type family ViewsOf (schema :: SchemaType) :: RelationsType where + ViewsOf '[] = '[] + ViewsOf (alias ::: 'View view ': schema) = + alias ::: view ': ViewsOf schema + ViewsOf (_ ': schema) = ViewsOf schema + +type family With + (relations :: RelationsType) + (schema :: SchemaType) + :: SchemaType where + With '[] schema = schema + With (alias ::: rel ': rels) schema = + alias ::: 'Table ('[] :=> RelationToColumns rel) ': With rels schema From 6cb59163b219985fccba29d36a12c0659b5f4379 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 9 Apr 2018 11:35:52 -0700 Subject: [PATCH 09/92] create drop and query views --- .../src/Squeal/PostgreSQL/Definition.hs | 38 ++++++++++++++----- .../src/Squeal/PostgreSQL/Expression.hs | 13 +++++++ .../src/Squeal/PostgreSQL/Query.hs | 7 ++++ 3 files changed, 49 insertions(+), 9 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 259db598..41d01165 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -64,6 +64,9 @@ module Squeal.PostgreSQL.Definition , setNotNull , dropNotNull , alterType + -- * Views + , createView + , dropView ) where import Control.Category @@ -77,6 +80,7 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC import Squeal.PostgreSQL.Expression +import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Schema @@ -122,8 +126,8 @@ createTable -> NP (Aliased (TableConstraintExpression schema1 table)) constraints -- ^ constraints that must hold for the table -> Definition schema0 schema1 -createTable table columns constraints = UnsafeDefinition $ - "CREATE TABLE" <+> renderCreation table columns constraints +createTable tab columns constraints = UnsafeDefinition $ + "CREATE TABLE" <+> renderCreation tab columns constraints -- | `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. -- Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. @@ -147,9 +151,9 @@ createTableIfNotExists -> NP (Aliased (TableConstraintExpression schema table)) constraints -- ^ constraints that must hold for the table -> Definition schema schema -createTableIfNotExists table columns constraints = UnsafeDefinition $ +createTableIfNotExists tab columns constraints = UnsafeDefinition $ "CREATE TABLE IF NOT EXISTS" - <+> renderCreation table columns constraints + <+> renderCreation tab columns constraints -- helper function for `createTable` and `createTableIfNotExists` renderCreation @@ -162,7 +166,7 @@ renderCreation -> NP (Aliased (TableConstraintExpression schema table)) constraints -- ^ constraints that must hold for the table -> ByteString -renderCreation table columns constraints = renderAlias table +renderCreation tab columns constraints = renderAlias tab <+> parenthesized ( renderCommaSeparated renderColumnDef columns <> ( case constraints of @@ -453,10 +457,10 @@ DROP statements -- >>> renderDefinition $ dropTable #muh_table -- "DROP TABLE \"muh_table\";" dropTable - :: KnownSymbol table + :: Has table schema ('Table t) => Alias table -- ^ table to remove -> Definition schema (Drop table schema) -dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";" +dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";" {----------------------------------------- ALTER statements @@ -468,9 +472,9 @@ alterTable => Alias alias -- ^ table to alter -> AlterTable alias table schema -- ^ alteration to perform -> Definition schema (Alter alias ('Table table) schema) -alterTable table alteration = UnsafeDefinition $ +alterTable tab alteration = UnsafeDefinition $ "ALTER TABLE" - <+> renderAlias table + <+> renderAlias tab <+> renderAlterTable alteration <> ";" @@ -731,3 +735,19 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;" alterType :: TypeExpression ty -> AlterColumn ty0 ty alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty + +createView + :: KnownSymbol view + => Alias view -- ^ the name of the table to add + -> Query schema '[] relation + -- ^ query + -> Definition schema (Create view ('View relation) schema) +createView alias query = UnsafeDefinition $ + "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS" + <+> renderQuery query <> ";" + +dropView + :: Has view schema ('View v) + => Alias view -- ^ view to remove + -> Definition schema (Drop view schema) +dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 485948b7..68312af0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -99,6 +99,7 @@ module Squeal.PostgreSQL.Expression , max_, maxDistinct, min_, minDistinct -- * Tables , Table (UnsafeTable, renderTable) + , View (UnsafeView, renderView) -- * Types , TypeExpression (UnsafeTypeExpression, renderTypeExpression) , PGTyped (pgtype) @@ -1036,6 +1037,18 @@ instance ) => IsLabel alias (Table schema relation) where fromLabel = UnsafeTable $ renderAlias (Alias @alias) +-- | A `View` from a table expression is a way +-- to call a table reference by its alias. +newtype View + (schema :: SchemaType) + (columns :: RelationType) + = UnsafeView { renderView :: ByteString } + deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance + ( Has alias (ViewsOf schema) columns + ) => IsLabel alias (View schema columns) where + fromLabel = UnsafeView $ renderAlias (Alias @alias) + {----------------------------------------- type expressions -----------------------------------------} diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 993b12f3..ebbaee04 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -58,6 +58,7 @@ module Squeal.PostgreSQL.Query , FromClause (..) , table , subquery + , view , crossJoin , innerJoin , leftOuterJoin @@ -612,6 +613,12 @@ subquery -> FromClause schema params '[table] subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery) +-- | `view` derives a table from a `View`. +view + :: Aliased (View schema) table + -> FromClause schema params '[table] +view = UnsafeFromClause . renderAliasedAs renderView + {- | @left & crossJoin right@. For every possible combination of rows from @left@ and @right@ (i.e., a Cartesian product), the joined table will contain a row consisting of all columns in @left@ followed by all columns in @right@. From fbd7a310fcba52cd0d1d4d244d146d6c96444c1e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 9 Apr 2018 11:59:57 -0700 Subject: [PATCH 10/92] fixing tests --- squeal-postgresql/exe/Example.hs | 8 ++--- squeal-postgresql/src/Squeal/PostgreSQL.hs | 8 ++--- .../src/Squeal/PostgreSQL/Definition.hs | 34 +++++++++++-------- .../src/Squeal/PostgreSQL/Manipulation.hs | 34 +++++++++---------- .../src/Squeal/PostgreSQL/Migration.hs | 34 +++++++++---------- .../src/Squeal/PostgreSQL/Query.hs | 34 +++++++++---------- 6 files changed, 79 insertions(+), 73 deletions(-) diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index c11f18e3..42c1ae38 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -25,20 +25,20 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC type Schema = - '[ "users" ::: + '[ "users" ::: 'Table ( '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2) - ] - , "emails" ::: + ]) + , "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 - ] + ]) ] setup :: Definition '[] Schema diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 8ac91045..b800bd51 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -31,19 +31,19 @@ -- -- >>> :{ -- type Schema = --- '[ "users" ::: +-- '[ "users" ::: 'Table ( -- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> -- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 -- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ] --- , "emails" ::: +-- ]) +-- , "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 --- ] +-- ]) -- ] -- :} -- diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 41d01165..f37b7d45 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -135,7 +135,7 @@ createTable tab columns constraints = UnsafeDefinition $ -- -- >>> :set -XOverloadedLabels -XTypeApplications -- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] --- >>> type Schema = '["tab" ::: Table] +-- >>> type Schema = '["tab" ::: 'Table Table] -- >>> :{ -- renderDefinition -- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema) @@ -210,10 +210,10 @@ newtype TableConstraintExpression -- -- >>> :{ -- type Schema = '[ --- "tab" ::: '[ "inequality" ::: 'Check '["a","b"]] :=> '[ +-- "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[ -- "a" ::: 'NoDef :=> 'NotNull 'PGint4, -- "b" ::: 'NoDef :=> 'NotNull 'PGint4 --- ]] +-- ])] -- :} -- -- >>> :{ @@ -241,10 +241,10 @@ check _cols condition = UnsafeTableConstraintExpression $ -- -- >>> :{ -- type Schema = '[ --- "tab" ::: '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[ +-- "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[ -- "a" ::: 'NoDef :=> 'Null 'PGint4, -- "b" ::: 'NoDef :=> 'Null 'PGint4 --- ]] +-- ])] -- :} -- -- >>> :{ @@ -272,10 +272,10 @@ unique columns = UnsafeTableConstraintExpression $ -- -- >>> :{ -- type Schema = '[ --- "tab" ::: '[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[ +-- "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[ -- "id" ::: 'Def :=> 'NotNull 'PGint4, -- "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ]] +-- ])] -- :} -- -- >>> :{ @@ -305,19 +305,19 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- -- >>> :{ -- type Schema = --- '[ "users" ::: +-- '[ "users" ::: 'Table ( -- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> -- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 -- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ] --- , "emails" ::: +-- ]) +-- , "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 --- ] +-- ]) -- ] -- :} -- @@ -344,14 +344,14 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- -- >>> :{ -- type Schema = --- '[ "employees" ::: +-- '[ "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 --- ] +-- ]) -- ] -- :} -- @@ -454,7 +454,13 @@ DROP statements -- | `dropTable` removes a table from the schema. -- --- >>> renderDefinition $ dropTable #muh_table +-- >>> :{ +-- let +-- definition :: Definition '["muh_table" ::: 'Table t] '[] +-- definition = dropTable #muh_table +-- :} +-- +-- >>> renderDefinition definition -- "DROP TABLE \"muh_table\";" dropTable :: Has table schema ('Table t) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index f1b9ebd0..4066281c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -73,9 +73,9 @@ simple insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[] + , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[] manipulation = insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) in renderManipulation manipulation @@ -87,9 +87,9 @@ parameterized insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[] manipulation = insertRow_ #tab @@ -103,9 +103,9 @@ returning insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] + , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '["fromOnly" ::: 'NotNull 'PGint4] manipulation = insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) @@ -119,9 +119,9 @@ upsert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "sum" ::: 'NotNull 'PGint4] manipulation = insertRows #tab @@ -140,14 +140,14 @@ query insert: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 - ] - , "other_tab" ::: '[] :=> + ]) + , "other_tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 - ] + ]) ] '[] '[] manipulation = insertQuery_ #tab @@ -161,9 +161,9 @@ update: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[] manipulation = update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) (#col1 ./= #col2) @@ -176,9 +176,9 @@ delete: >>> :{ let manipulation :: Manipulation - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "col1" ::: 'NotNull 'PGint4 , "col2" ::: 'NotNull 'PGint4 ] manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar @@ -482,7 +482,7 @@ WITH statements -- -- >>> :{ -- let --- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[] +-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[] -- manipulation = with -- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil) -- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t))))) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index c36489e2..54e44dd4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -31,7 +31,7 @@ type EmailsTable = >>> :{ let - makeUsers :: Migration IO '[] '["users" ::: UsersTable] + makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable] makeUsers = Migration { name = "make users table" , up = void . define $ @@ -45,8 +45,8 @@ let >>> :{ let - makeEmails :: Migration IO '["users" ::: UsersTable] - '["users" ::: UsersTable, "emails" ::: EmailsTable] + makeEmails :: Migration IO '["users" ::: 'Table UsersTable] + '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable] makeEmails = Migration { name = "make emails table" , up = void . define $ @@ -68,7 +68,7 @@ Now that we have a couple migrations we can chain them together. >>> :{ let numMigrations - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" (TablesOf schema) MigrationsTable => PQ schema schema IO () numMigrations = do result <- runQuery (selectStar (from (table (#schema_migrations `As` #m)))) @@ -175,8 +175,8 @@ migrateUp migration = :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io () upMigrations = \case Done -> return () @@ -185,8 +185,8 @@ migrateUp migration = upMigration :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io () upMigration step = queryExecuted step @@ -202,8 +202,8 @@ migrateUp migration = queryExecuted :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io Row queryExecuted step = do result <- runQueryParams selectMigration (Only (name step)) @@ -230,8 +230,8 @@ migrateDown migrations = downMigrations :: MonadBaseControl IO io => AlignedList (Migration io) schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io () downMigrations = \case Done -> return () @@ -240,8 +240,8 @@ migrateDown migrations = downMigration :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema0) io () downMigration step = queryExecuted step @@ -257,8 +257,8 @@ migrateDown migrations = queryExecuted :: MonadBase IO io => Migration io schema0 schema1 -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) + ("schema_migrations" ::: 'Table MigrationsTable ': schema1) io Row queryExecuted step = do result <- runQueryParams selectMigration (Only (name step)) @@ -309,7 +309,7 @@ deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1) -- | Selects a `Migration` from the `MigrationsTable`, returning -- the time at which it was executed. selectMigration - :: Has "schema_migrations" schema MigrationsTable + :: Has "schema_migrations" (TablesOf schema) MigrationsTable => Query schema '[ 'NotNull 'PGtext ] '[ "executed_at" ::: 'NotNull 'PGtimestamptz ] selectMigration = select diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index ebbaee04..dfd2d206 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -101,7 +101,7 @@ simple query: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectStar (from (table (#tab `As` #t))) @@ -114,9 +114,9 @@ restricted query: >>> :{ let query :: Query - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "sum" ::: 'NotNull 'PGint4 , "col1" ::: 'NotNull 'PGint4 ] @@ -135,7 +135,7 @@ subquery: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = @@ -150,7 +150,7 @@ limits and offsets: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectStar @@ -164,7 +164,7 @@ parameterized query: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])] '[ 'NotNull 'PGfloat8] '["col" ::: 'NotNull 'PGfloat8] query = selectStar @@ -178,9 +178,9 @@ aggregation query: >>> :{ let query :: Query - '[ "tab" ::: '[] :=> + '[ "tab" ::: 'Table ('[] :=> '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4 - , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] + , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[ "sum" ::: 'NotNull 'PGint4 , "col1" ::: 'NotNull 'PGint4 ] @@ -198,7 +198,7 @@ sorted query: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectStar @@ -213,7 +213,7 @@ joins: >>> :{ let query :: Query - '[ "orders" ::: + '[ "orders" ::: 'Table ( '["pk_orders" ::: PrimaryKey '["id"] ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"] ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=> @@ -221,17 +221,17 @@ let , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4 , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4 , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 - ] - , "customers" ::: + ]) + , "customers" ::: 'Table ( '["pk_customers" ::: PrimaryKey '["id"]] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] - , "shippers" ::: + ]) + , "shippers" ::: 'Table ( '["pk_shippers" ::: PrimaryKey '["id"]] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] + ]) ] '[] '[ "order_price" ::: 'NotNull 'PGfloat4 @@ -256,7 +256,7 @@ self-join: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = selectDotStar #t1 @@ -270,7 +270,7 @@ set operations: >>> :{ let query :: Query - '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] + '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] query = From d01eae41a47aac08addd1bc9d59216b60ed14ea8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 11:08:33 -0700 Subject: [PATCH 11/92] fix tests --- .../src/Squeal/PostgreSQL/Definition.hs | 50 +++++++++---------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index f37b7d45..31ae6445 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -511,8 +511,8 @@ newtype AlterTable -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0))) -- in renderDefinition definition -- :} @@ -535,8 +535,8 @@ addConstraint alias constraint = UnsafeAlterTable $ -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] +-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (dropConstraint #positive) -- in renderDefinition definition -- :} @@ -560,10 +560,10 @@ class AddColumn ty where -- >>> :{ -- let -- definition :: Definition - -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] - -- '["tab" ::: '[] :=> + -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] + -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'Def :=> 'Null 'PGtext ]] + -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo")) -- in renderDefinition definition -- :} @@ -572,10 +572,10 @@ class AddColumn ty where -- >>> :{ -- let -- definition :: Definition - -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] - -- '["tab" ::: '[] :=> + -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] + -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]] + -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] -- definition = alterTable #tab (addColumn #col2 text) -- in renderDefinition definition -- :} @@ -601,10 +601,10 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> +-- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 --- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]] --- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]] +-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] +-- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (dropColumn #col2) -- in renderDefinition definition -- :} @@ -624,8 +624,8 @@ dropColumn column = UnsafeAlterTable $ -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (renameColumn #foo #bar) -- in renderDefinition definition -- :} @@ -667,8 +667,8 @@ newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) = -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col (setDefault 5)) -- in renderDefinition definition -- :} @@ -684,8 +684,8 @@ setDefault expression = UnsafeAlterColumn $ -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropDefault) -- in renderDefinition definition -- :} @@ -700,8 +700,8 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (alterColumn #col setNotNull) -- in renderDefinition definition -- :} @@ -715,8 +715,8 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropNotNull) -- in renderDefinition definition -- :} @@ -732,8 +732,8 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- >>> :{ -- let -- definition :: Definition --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]] --- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] +-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])] -- definition = -- alterTable #tab (alterColumn #col (alterType (numeric & notNull))) -- in renderDefinition definition From b95400d8028138576423ad596b7376f97ca732ef Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 11:18:18 -0700 Subject: [PATCH 12/92] doctest for create view --- .../src/Squeal/PostgreSQL/Definition.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 31ae6445..9d12b2da 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -742,6 +742,18 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" alterType :: TypeExpression ty -> AlterColumn ty0 ty alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty +-- | create a view... +-- >>> :{ +-- let +-- definition :: Definition +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])] +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) +-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] +-- definition = +-- createView #bc (select (#b `As` #b :* #c `As` #c :* Nil) (from (table (#abc `As` #abc)))) +-- in renderDefinition definition +-- :} +-- "CREATE VIEW \"bc\" AS SELECT \"b\" AS \"b\", \"c\" AS \"c\" FROM \"abc\" AS \"abc\";" createView :: KnownSymbol view => Alias view -- ^ the name of the table to add From 875f8f83996f645f549312d3ee55b141e94ba217 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 11:29:13 -0700 Subject: [PATCH 13/92] simplify a bit --- .../src/Squeal/PostgreSQL/Definition.hs | 24 +++++++++---------- .../src/Squeal/PostgreSQL/Expression.hs | 4 ++-- .../src/Squeal/PostgreSQL/Manipulation.hs | 20 ++++++++-------- .../src/Squeal/PostgreSQL/Migration.hs | 10 ++++---- .../src/Squeal/PostgreSQL/Schema.hs | 14 ----------- 5 files changed, 29 insertions(+), 43 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 9d12b2da..d83e504b 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -142,7 +142,7 @@ createTable tab columns constraints = UnsafeDefinition $ -- :} -- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int, \"b\" real);" createTableIfNotExists - :: ( Has table (TablesOf schema) (constraints :=> columns) + :: ( Has table schema ('Table (constraints :=> columns)) , SOP.SListI columns , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add @@ -228,7 +228,7 @@ newtype TableConstraintExpression -- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));" check - :: ( Has alias (TablesOf schema) table + :: ( Has alias schema ('Table table) , HasAll aliases (TableToColumns table) subcolumns ) => NP Alias aliases -> (forall tab. Condition '[tab ::: ColumnsToRelation subcolumns] 'Ungrouped '[]) @@ -259,7 +259,7 @@ check _cols condition = UnsafeTableConstraintExpression $ -- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" unique - :: ( Has alias (TablesOf schema) table + :: ( Has alias schema ('Table table) , HasAll aliases (TableToColumns table) subcolumns ) => NP Alias aliases -> TableConstraintExpression schema alias ('Unique aliases) @@ -290,7 +290,7 @@ unique columns = UnsafeTableConstraintExpression $ -- >>> renderDefinition definition -- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));" primaryKey - :: ( Has alias (TablesOf schema) table + :: ( Has alias schema ('Table table) , HasAll aliases (TableToColumns table) subcolumns , AllNotNull subcolumns ) => NP Alias aliases @@ -401,8 +401,8 @@ type ForeignKeyed schema columns refcolumns constraints cols reftys tys = - ( Has child (TablesOf schema) table - , Has parent (TablesOf schema) reftable + ( Has child schema ('Table table) + , Has parent schema ('Table reftable) , HasAll columns (TableToColumns table) tys , reftable ~ (constraints :=> cols) , HasAll refcolumns cols reftys @@ -519,7 +519,7 @@ newtype AlterTable -- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));" addConstraint :: ( KnownSymbol alias - , Has tab (TablesOf schema) table0 + , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (Create alias constraint constraints :=> columns) ) => Alias alias @@ -543,7 +543,7 @@ addConstraint alias constraint = UnsafeAlterTable $ -- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";" dropConstraint :: ( KnownSymbol constraint - , Has tab (TablesOf schema) table0 + , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (Drop constraint constraints :=> columns) ) => Alias constraint @@ -582,7 +582,7 @@ class AddColumn ty where -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;" addColumn :: ( KnownSymbol column - , Has tab (TablesOf schema) table0 + , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Create column ty columns) ) => Alias column -- ^ column to add @@ -611,7 +611,7 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";" dropColumn :: ( KnownSymbol column - , Has tab (TablesOf schema) table0 + , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Drop column columns) ) => Alias column -- ^ column to remove @@ -633,7 +633,7 @@ dropColumn column = UnsafeAlterTable $ renameColumn :: ( KnownSymbol column0 , KnownSymbol column1 - , Has tab (TablesOf schema) table0 + , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Rename column0 column1 columns) ) => Alias column0 -- ^ column to rename @@ -645,7 +645,7 @@ renameColumn column0 column1 = UnsafeAlterTable $ -- | An `alterColumn` alters a single column. alterColumn :: ( KnownSymbol column - , Has tab (TablesOf schema) table0 + , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , Has column columns ty0 , tables1 ~ (constraints :=> Alter column ty1 columns)) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 68312af0..5a271f2c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -1032,7 +1032,7 @@ newtype Table = UnsafeTable { renderTable :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) instance - ( Has alias (TablesOf schema) table + ( Has alias schema ('Table table) , relation ~ ColumnsToRelation (TableToColumns table) ) => IsLabel alias (Table schema relation) where fromLabel = UnsafeTable $ renderAlias (Alias @alias) @@ -1045,7 +1045,7 @@ newtype View = UnsafeView { renderView :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) instance - ( Has alias (ViewsOf schema) columns + ( Has alias schema ('View columns) ) => IsLabel alias (View schema columns) where fromLabel = UnsafeView $ renderAlias (Alias @alias) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index 4066281c..5fe4e196 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -213,7 +213,7 @@ INSERT statements insertRows :: ( SOP.SListI columns , SOP.SListI results - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -243,7 +243,7 @@ insertRows tab row rows conflict returning = UnsafeManipulation $ insertRow :: ( SOP.SListI columns , SOP.SListI results - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -256,7 +256,7 @@ insertRow tab row = insertRows tab row [] -- | Insert multiple rows returning `Nil` and raising an error on conflicts. insertRows_ :: ( SOP.SListI columns - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -268,7 +268,7 @@ insertRows_ tab row rows = -- | Insert a single row returning `Nil` and raising an error on conflicts. insertRow_ :: ( SOP.SListI columns - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert @@ -279,7 +279,7 @@ insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil) insertQuery :: ( SOP.SListI columns , SOP.SListI results - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) @@ -296,7 +296,7 @@ insertQuery tab query conflict returning = UnsafeManipulation $ -- | Insert a `Query` returning `Nil` and raising an error on conflicts. insertQuery_ :: ( SOP.SListI columns - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) @@ -401,7 +401,7 @@ UPDATE statements update :: ( SOP.SListI columns , SOP.SListI results - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to update -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns @@ -431,7 +431,7 @@ update tab columns wh returning = UnsafeManipulation $ -- | Update a row returning `Nil`. update_ :: ( SOP.SListI columns - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to update -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns @@ -448,7 +448,7 @@ DELETE statements -- | Delete rows of a table. deleteFrom :: ( SOP.SListI results - , Has tab (TablesOf schema) table + , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params @@ -462,7 +462,7 @@ deleteFrom tab wh returning = UnsafeManipulation $ -- | Delete rows returning `Nil`. deleteFrom_ - :: ( Has tab (TablesOf schema) table + :: ( Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 54e44dd4..3d81de23 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -68,7 +68,7 @@ Now that we have a couple migrations we can chain them together. >>> :{ let numMigrations - :: Has "schema_migrations" (TablesOf schema) MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => PQ schema schema IO () numMigrations = do result <- runQuery (selectStar (from (table (#schema_migrations `As` #m)))) @@ -283,7 +283,7 @@ type MigrationsTable = -- | Creates a `MigrationsTable` if it does not already exist. createMigrations - :: Has "schema_migrations" (TablesOf schema) MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Definition schema schema createMigrations = createTableIfNotExists #schema_migrations @@ -294,7 +294,7 @@ createMigrations = -- | Inserts a `Migration` into the `MigrationsTable` insertMigration - :: Has "schema_migrations" (TablesOf schema) MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Manipulation schema '[ 'NotNull 'PGtext] '[] insertMigration = insertRow_ #schema_migrations ( Set (param @1) `As` #name :* @@ -302,14 +302,14 @@ insertMigration = insertRow_ #schema_migrations -- | Deletes a `Migration` from the `MigrationsTable` deleteMigration - :: Has "schema_migrations" (TablesOf schema) MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Manipulation schema '[ 'NotNull 'PGtext ] '[] deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1) -- | Selects a `Migration` from the `MigrationsTable`, returning -- the time at which it was executed. selectMigration - :: Has "schema_migrations" (TablesOf schema) MigrationsTable + :: Has "schema_migrations" schema ('Table MigrationsTable) => Query schema '[ 'NotNull 'PGtext ] '[ "executed_at" ::: 'NotNull 'PGtimestamptz ] selectMigration = select diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 01f9b646..9b74b289 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -102,8 +102,6 @@ module Squeal.PostgreSQL.Schema -- * Schema , SchemumType (..) , SchemaType - , TablesOf - , ViewsOf , With ) where @@ -624,18 +622,6 @@ data SchemumType type SchemaType = [(Symbol,SchemumType)] -type family TablesOf (schema :: SchemaType) :: TablesType where - TablesOf '[] = '[] - TablesOf (alias ::: 'Table table ': schema) = - alias ::: table ': TablesOf schema - TablesOf (_ ': schema) = TablesOf schema - -type family ViewsOf (schema :: SchemaType) :: RelationsType where - ViewsOf '[] = '[] - ViewsOf (alias ::: 'View view ': schema) = - alias ::: view ': ViewsOf schema - ViewsOf (_ ': schema) = ViewsOf schema - type family With (relations :: RelationsType) (schema :: SchemaType) From 520e294684578ac733e9a5da42077482e56b64d2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 15:31:00 -0700 Subject: [PATCH 14/92] more sql types types * Add `PGenum` and `PGcomposite` types * Add `Typedef` schemum * `createTypeEnum` statements * Split `ColumnTypeExpression` from `TypeExpression` --- README.md | 2 +- squeal-postgresql/exe/Example.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL.hs | 4 +- .../src/Squeal/PostgreSQL/Definition.hs | 130 +++++++++++++----- .../src/Squeal/PostgreSQL/Expression.hs | 98 ++++--------- .../src/Squeal/PostgreSQL/Migration.hs | 2 +- .../src/Squeal/PostgreSQL/Schema.hs | 3 + 7 files changed, 135 insertions(+), 106 deletions(-) diff --git a/README.md b/README.md index 8bfd94c4..d9b20609 100644 --- a/README.md +++ b/README.md @@ -132,7 +132,7 @@ let createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* - text `As` #email :* Nil ) + (text & null') `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index 42c1ae38..415bd4f0 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -52,7 +52,7 @@ setup = createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* - text `As` #email :* Nil ) + (text & null') `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index b800bd51..2b5f34a6 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -71,7 +71,7 @@ -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* --- text `As` #email :* Nil ) +-- (text & null') `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) @@ -80,7 +80,7 @@ -- We can easily see the generated SQL is unsuprising looking. -- -- >>> renderDefinition 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, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" +-- "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);" -- -- Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@. -- In our `createTable` commands we included `TableConstraint`s to define diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index d83e504b..f69008f5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -67,6 +67,17 @@ module Squeal.PostgreSQL.Definition -- * Views , createView , dropView + , createTypeEnum + , ColumnTypeExpression (..) + , notNull + , null' + , default_ + , serial2 + , smallserial + , serial4 + , serial + , serial8 + , bigserial ) where import Control.Category @@ -111,9 +122,9 @@ CREATE statements -- >>> :set -XOverloadedLabels -- >>> :{ -- renderDefinition $ --- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil +-- createTable #tab ((int & null') `As` #a :* (real & null') `As` #b :* Nil) Nil -- :} --- "CREATE TABLE \"tab\" (\"a\" int, \"b\" real);" +-- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTable :: ( KnownSymbol table , columns ~ (col ': cols) @@ -121,7 +132,7 @@ createTable , SOP.SListI constraints , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 ) => Alias table -- ^ the name of the table to add - -> NP (Aliased TypeExpression) columns + -> NP (Aliased (ColumnTypeExpression schema0)) columns -- ^ the names and datatype of each column -> NP (Aliased (TableConstraintExpression schema1 table)) constraints -- ^ constraints that must hold for the table @@ -138,15 +149,15 @@ createTable tab columns constraints = UnsafeDefinition $ -- >>> type Schema = '["tab" ::: 'Table Table] -- >>> :{ -- renderDefinition --- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema) +-- (createTableIfNotExists #tab ((int & null') `As` #a :* (real & null') `As` #b :* Nil) Nil :: Definition Schema Schema) -- :} --- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int, \"b\" real);" +-- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTableIfNotExists :: ( Has table schema ('Table (constraints :=> columns)) , SOP.SListI columns , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add - -> NP (Aliased TypeExpression) columns + -> NP (Aliased (ColumnTypeExpression schema)) columns -- ^ the names and datatype of each column -> NP (Aliased (TableConstraintExpression schema table)) constraints -- ^ constraints that must hold for the table @@ -161,9 +172,9 @@ renderCreation , SOP.SListI columns , SOP.SListI constraints ) => Alias table -- ^ the name of the table to add - -> NP (Aliased TypeExpression) columns + -> NP (Aliased (ColumnTypeExpression schema0)) columns -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression schema table)) constraints + -> NP (Aliased (TableConstraintExpression schema1 table)) constraints -- ^ constraints that must hold for the table -> ByteString renderCreation tab columns constraints = renderAlias tab @@ -175,9 +186,9 @@ renderCreation tab columns constraints = renderAlias tab renderCommaSeparated renderConstraint constraints ) ) <> ";" where - renderColumnDef :: Aliased TypeExpression x -> ByteString + renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString renderColumnDef (ty `As` column) = - renderAlias column <+> renderTypeExpression ty + renderAlias column <+> renderColumnTypeExpression ty renderConstraint :: Aliased (TableConstraintExpression schema columns) constraint -> ByteString @@ -251,13 +262,13 @@ check _cols condition = UnsafeTableConstraintExpression $ -- let -- definition :: Definition '[] Schema -- definition = createTable #tab --- ( int `As` #a :* --- int `As` #b :* Nil ) +-- ( (int & null') `As` #a :* +-- (int & null') `As` #b :* Nil ) -- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) -- :} -- -- >>> renderDefinition definition --- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" +-- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" int NULL, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" unique :: ( Has alias schema ('Table table) , HasAll aliases (TableToColumns table) subcolumns ) @@ -332,13 +343,13 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* --- text `As` #email :* Nil ) +-- (text & null') `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) -- in renderDefinition 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, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" +-- "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. -- @@ -362,13 +373,13 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- createTable #employees -- ( serial `As` #id :* -- (text & notNull) `As` #name :* --- integer `As` #employer_id :* Nil ) +-- (integer & null') `As` #employer_id :* Nil ) -- ( primaryKey #id `As` #employees_pk :* -- foreignKey #employer_id #employees #id -- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) -- in renderDefinition setup -- :} --- "CREATE TABLE \"employees\" (\"id\" serial, \"name\" text NOT NULL, \"employer_id\" integer, CONSTRAINT \"employees_pk\" PRIMARY KEY (\"id\"), CONSTRAINT \"employees_employer_fk\" FOREIGN KEY (\"employer_id\") REFERENCES \"employees\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);" +-- "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 schema child parent @@ -564,10 +575,10 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo")) + -- definition = alterTable #tab (addColumn #col2 (text & null' & default_ "foo")) -- in renderDefinition definition -- :} - -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text DEFAULT E'foo';" + -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL DEFAULT E'foo';" -- -- >>> :{ -- let @@ -576,20 +587,20 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 text) + -- definition = alterTable #tab (addColumn #col2 (text & null')) -- in renderDefinition definition -- :} - -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;" + -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL;" addColumn :: ( KnownSymbol column , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Create column ty columns) ) => Alias column -- ^ column to add - -> TypeExpression ty -- ^ type of the new column + -> ColumnTypeExpression schema ty -- ^ type of the new column -> AlterTable tab table1 schema addColumn column ty = UnsafeAlterTable $ - "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty + "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) @@ -650,13 +661,13 @@ alterColumn , Has column columns ty0 , tables1 ~ (constraints :=> Alter column ty1 columns)) => Alias column -- ^ column to alter - -> AlterColumn ty0 ty1 -- ^ alteration to perform + -> AlterColumn schema ty0 ty1 -- ^ alteration to perform -> AlterTable tab table1 schema alterColumn column alteration = UnsafeAlterTable $ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration -- | An `AlterColumn` describes the alteration to perform on a single column. -newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) = +newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) = UnsafeAlterColumn {renderAlterColumn :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -675,7 +686,7 @@ newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) = -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET DEFAULT 5;" setDefault :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set - -> AlterColumn (constraint :=> ty) ('Def :=> ty) + -> AlterColumn schema (constraint :=> ty) ('Def :=> ty) setDefault expression = UnsafeAlterColumn $ "SET DEFAULT" <+> renderExpression expression @@ -690,7 +701,7 @@ setDefault expression = UnsafeAlterColumn $ -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP DEFAULT;" -dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty) +dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty) dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- | A `setNotNull` adds a @NOT NULL@ constraint to a column. @@ -707,7 +718,7 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET NOT NULL;" setNotNull - :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) + :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- | A `dropNotNull` drops a @NOT NULL@ constraint from a column. @@ -722,7 +733,7 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP NOT NULL;" dropNotNull - :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) + :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- | An `alterType` converts a column to a different data type. @@ -739,8 +750,8 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;" -alterType :: TypeExpression ty -> AlterColumn ty0 ty -alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty +alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty +alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty -- | create a view... -- >>> :{ @@ -769,3 +780,60 @@ dropView => Alias view -- ^ view to remove -> Definition schema (Drop view schema) dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" + +createTypeEnum + :: (KnownSymbol enum, SOP.All KnownSymbol labels) + => Alias enum + -> NP Alias labels + -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) +createTypeEnum enum labels = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> + parenthesized (commaSeparated (renderAliases labels)) <> ";" + +-- | `ColumnTypeExpression`s are used in `createTable` commands. +newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType) + = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } + deriving (GHC.Generic,Show,Eq,Ord,NFData) + +instance (Has alias schema ('Typedef ty)) + => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where + fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias)) + +null' + :: TypeExpression ty + -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) +null' ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" + +-- | used in `createTable` commands as a column constraint to ensure +-- @NULL@ is not present +notNull + :: TypeExpression ty + -> ColumnTypeExpression schema (def :=> 'NotNull ty) +notNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" + +-- | used in `createTable` commands as a column constraint to give a default +default_ + :: Expression '[] 'Ungrouped '[] ty + -> ColumnTypeExpression schema ('NoDef :=> ty) + -> ColumnTypeExpression schema ('Def :=> ty) +default_ x ty = UnsafeColumnTypeExpression $ + renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x + +-- | not a true type, but merely a notational convenience for creating +-- unique identifier columns with type `'PGint2` +serial2, smallserial + :: ColumnTypeExpression schema ('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 schema ('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 schema ('Def :=> 'NotNull 'PGint8) +serial8 = UnsafeColumnTypeExpression "serial8" +bigserial = UnsafeColumnTypeExpression "bigserial" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 5a271f2c..5bbcceb4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -116,12 +116,6 @@ module Squeal.PostgreSQL.Expression , real , float8 , doublePrecision - , serial2 - , smallserial - , serial4 - , serial - , serial8 - , bigserial , text , char , character @@ -140,8 +134,6 @@ module Squeal.PostgreSQL.Expression , jsonb , vararray , fixarray - , notNull - , default_ -- * Re-export , (&) , NP ((:*), Nil) @@ -452,7 +444,7 @@ atan2_ y x = UnsafeExpression $ -- | >>> renderExpression $ true & cast int4 -- "(TRUE :: int4)" cast - :: TypeExpression ('NoDef :=> 'Null ty1) + :: TypeExpression ty1 -- ^ type to cast as -> Expression relations grouping params (nullity ty0) -- ^ value to convert @@ -1054,110 +1046,92 @@ type expressions -----------------------------------------} -- | `TypeExpression`s are used in `cast`s and `createTable` commands. -newtype TypeExpression (ty :: ColumnType) +newtype TypeExpression (ty :: PGType) = UnsafeTypeExpression { renderTypeExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) -- | logical Boolean (true/false) -bool :: TypeExpression ('NoDef :=> 'Null 'PGbool) +bool :: TypeExpression 'PGbool bool = UnsafeTypeExpression "bool" -- | signed two-byte integer -int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2) +int2, smallint :: TypeExpression 'PGint2 int2 = UnsafeTypeExpression "int2" smallint = UnsafeTypeExpression "smallint" -- | signed four-byte integer -int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4) +int4, int, integer :: TypeExpression 'PGint4 int4 = UnsafeTypeExpression "int4" int = UnsafeTypeExpression "int" integer = UnsafeTypeExpression "integer" -- | signed eight-byte integer -int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8) +int8, bigint :: TypeExpression 'PGint8 int8 = UnsafeTypeExpression "int8" bigint = UnsafeTypeExpression "bigint" -- | arbitrary precision numeric type -numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric) +numeric :: TypeExpression 'PGnumeric numeric = UnsafeTypeExpression "numeric" -- | single precision floating-point number (4 bytes) -float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4) +float4, real :: TypeExpression 'PGfloat4 float4 = UnsafeTypeExpression "float4" real = UnsafeTypeExpression "real" -- | double precision floating-point number (8 bytes) -float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8) +float8, doublePrecision :: TypeExpression 'PGfloat8 float8 = UnsafeTypeExpression "float8" doublePrecision = UnsafeTypeExpression "double precision" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint2` -serial2, smallserial - :: TypeExpression ('Def :=> 'NotNull 'PGint2) -serial2 = UnsafeTypeExpression "serial2" -smallserial = UnsafeTypeExpression "smallserial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint4` -serial4, serial - :: TypeExpression ('Def :=> 'NotNull 'PGint4) -serial4 = UnsafeTypeExpression "serial4" -serial = UnsafeTypeExpression "serial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint8` -serial8, bigserial - :: TypeExpression ('Def :=> 'NotNull 'PGint8) -serial8 = UnsafeTypeExpression "serial8" -bigserial = UnsafeTypeExpression "bigserial" -- | variable-length character string -text :: TypeExpression ('NoDef :=> 'Null 'PGtext) +text :: TypeExpression 'PGtext text = UnsafeTypeExpression "text" -- | fixed-length character string char, character :: (KnownNat n, 1 <= n) => proxy n - -> TypeExpression ('NoDef :=> 'Null ('PGchar n)) + -> TypeExpression ('PGchar n) char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")" character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")" -- | variable-length character string varchar, characterVarying :: (KnownNat n, 1 <= n) => proxy n - -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n)) + -> TypeExpression ('PGvarchar n) varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")" characterVarying p = UnsafeTypeExpression $ "character varying(" <> renderNat p <> ")" -- | binary data ("byte array") -bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea) +bytea :: TypeExpression 'PGbytea bytea = UnsafeTypeExpression "bytea" -- | date and time (no time zone) -timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp) +timestamp :: TypeExpression 'PGtimestamp timestamp = UnsafeTypeExpression "timestamp" -- | date and time, including time zone -timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz) +timestampWithTimeZone :: TypeExpression 'PGtimestamptz timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone" -- | calendar date (year, month, day) -date :: TypeExpression ('NoDef :=> 'Null 'PGdate) +date :: TypeExpression 'PGdate date = UnsafeTypeExpression "date" -- | time of day (no time zone) -time :: TypeExpression ('NoDef :=> 'Null 'PGtime) +time :: TypeExpression 'PGtime time = UnsafeTypeExpression "time" -- | time of day, including time zone -timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz) +timeWithTimeZone :: TypeExpression 'PGtimetz timeWithTimeZone = UnsafeTypeExpression "time with time zone" -- | time span -interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval) +interval :: TypeExpression 'PGinterval interval = UnsafeTypeExpression "interval" -- | universally unique identifier -uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid) +uuid :: TypeExpression 'PGuuid uuid = UnsafeTypeExpression "uuid" -- | IPv4 or IPv6 host address -inet :: TypeExpression ('NoDef :=> 'Null 'PGinet) +inet :: TypeExpression 'PGinet inet = UnsafeTypeExpression "inet" -- | textual JSON data -json :: TypeExpression ('NoDef :=> 'Null 'PGjson) +json :: TypeExpression 'PGjson json = UnsafeTypeExpression "json" -- | binary JSON data, decomposed -jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb) +jsonb :: TypeExpression 'PGjsonb jsonb = UnsafeTypeExpression "jsonb" -- | variable length array vararray - :: TypeExpression ('NoDef :=> 'Null pg) - -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg)) + :: TypeExpression pg + -> TypeExpression ('PGvararray pg) vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]" -- | fixed length array -- @@ -1166,29 +1140,13 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]" fixarray :: KnownNat n => proxy n - -> TypeExpression ('NoDef :=> 'Null pg) - -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg)) + -> TypeExpression pg + -> TypeExpression ('PGfixarray n pg) fixarray p ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[" <> renderNat p <> "]" --- | used in `createTable` commands as a column constraint to ensure --- @NULL@ is not present -notNull - :: TypeExpression (def :=> 'Null ty) - -> TypeExpression (def :=> 'NotNull ty) -notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL" - --- | used in `createTable` commands as a column constraint to give a default -default_ - :: Expression '[] 'Ungrouped '[] ty - -> TypeExpression ('NoDef :=> ty) - -> TypeExpression ('Def :=> ty) -default_ x ty = UnsafeTypeExpression $ - renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x - -- | `pgtype` is a demoted version of a `PGType` -class PGTyped (ty :: PGType) where - pgtype :: TypeExpression ('NoDef :=> 'Null ty) +class PGTyped (ty :: PGType) where pgtype :: TypeExpression ty instance PGTyped 'PGbool where pgtype = bool instance PGTyped 'PGint2 where pgtype = int2 instance PGTyped 'PGint4 where pgtype = int4 diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 3d81de23..9db68b30 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -53,7 +53,7 @@ let createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* - text `As` #email :* Nil ) + (text & null') `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 9b74b289..a7ca0af0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -150,6 +150,8 @@ data PGType | PGjsonb -- ^ binary JSON data, decomposed | PGvararray PGType -- ^ variable length array | PGfixarray Nat PGType -- ^ fixed length array + | PGenum [Symbol] + | PGcomposite [(Symbol, PGType)] | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types -- | The object identifier of a `PGType`. @@ -619,6 +621,7 @@ type family DropIfConstraintsInvolve column constraints where data SchemumType = Table TableType | View RelationType + | Typedef PGType type SchemaType = [(Symbol,SchemumType)] From d6c0a437bef507a6aae5d0a373b9c9af21aba8a9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 15:51:22 -0700 Subject: [PATCH 15/92] create composite types --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index f69008f5..c13d9db1 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -67,6 +67,8 @@ module Squeal.PostgreSQL.Definition -- * Views , createView , dropView + -- * Types + , createType , createTypeEnum , ColumnTypeExpression (..) , notNull @@ -790,6 +792,15 @@ createTypeEnum enum labels = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> parenthesized (commaSeparated (renderAliases labels)) <> ";" +createType + :: (KnownSymbol comp, SOP.SListI fields) + => Alias comp + -> NP (Aliased TypeExpression) fields + -> Definition schema (Create comp ('Typedef ('PGcomposite fields)) schema) +createType comp fields = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized + (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) + -- | `ColumnTypeExpression`s are used in `createTable` commands. newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType) = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } From ea020d180418c324e081a4a6ef2434e5b6862154 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 15:58:50 -0700 Subject: [PATCH 16/92] dropType --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index c13d9db1..256b3bfd 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -70,6 +70,7 @@ module Squeal.PostgreSQL.Definition -- * Types , createType , createTypeEnum + , dropType , ColumnTypeExpression (..) , notNull , null' @@ -799,7 +800,13 @@ createType -> Definition schema (Create comp ('Typedef ('PGcomposite fields)) schema) createType comp fields = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized - (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) + (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";" + +dropType + :: Has tydef schema ('Typedef ty) + => Alias tydef + -> Definition schema (Drop tydef schema) +dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";" -- | `ColumnTypeExpression`s are used in `createTable` commands. newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType) From d34c70c22c01c25896c4b585f208259c0772457b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 10 Apr 2018 20:24:54 -0700 Subject: [PATCH 17/92] decode composite values --- squeal-postgresql/squeal-postgresql.cabal | 1 + .../src/Squeal/PostgreSQL/Binary.hs | 59 +++++++++++++++++++ .../src/Squeal/PostgreSQL/Schema.hs | 2 +- 3 files changed, 61 insertions(+), 1 deletion(-) diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index b7872e78..8ee48e6a 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -38,6 +38,7 @@ library build-depends: aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 + , binary-parser , bytestring >= 0.10.8.2 , deepseq >= 1.4.3.0 , generics-sop >= 0.3.2.0 diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 4ebd8c04..d5e801a7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -25,6 +25,7 @@ Binary encoding and decoding between Haskell and PostgreSQL types. , ScopedTypeVariables , TypeApplications , TypeFamilies + , TypeFamilyDependencies , TypeInType , TypeOperators , UndecidableInstances @@ -43,6 +44,7 @@ module Squeal.PostgreSQL.Binary , Only (..) ) where +import BinaryParser import Data.Aeson hiding (Null) import Data.Int import Data.Kind @@ -202,6 +204,63 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where (Decoding.dimensionArray Vector.replicateM (Decoding.nullableValueArray (fromValue (Proxy @pg)))) +class IsMaybes (xs :: [Type]) where + type family Maybes xs = (mxs :: [Type]) | mxs -> xs + maybes :: NP Maybe xs -> NP I (Maybes xs) + +instance IsMaybes '[] where + type Maybes '[] = '[] + maybes Nil = Nil + +instance IsMaybes xs => IsMaybes (x ': xs) where + type Maybes (x ': xs) = Maybe x ': Maybes xs + maybes (x :* xs) = I x :* maybes xs + +class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where + fromAliasedValue :: proxy pg -> Decoding.Value y +instance FromValue pg y => FromAliasedValue (alias ::: pg) y where + fromAliasedValue _ = fromValue (Proxy @pg) + +instance + ( SListI fields + , IsMaybes ys + , IsProductType y (Maybes ys) + , AllZip FromAliasedValue fields ys + , SameFields (DatatypeInfoOf y) fields + ) => FromValue ('PGcomposite fields) y where + fromValue = fmap (to . SOP . Z . maybes) . composite . decoders + +decoders + :: forall pgs ys proxy + . AllZip FromAliasedValue pgs ys + => proxy ('PGcomposite pgs) + -> NP Decoding.Value ys +decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue + (hpure Proxy :: NP Proxy pgs) + +composite + :: SListI ys + => NP Decoding.Value ys + -> Decoding.Value (NP Maybe ys) +composite decoders = do +-- [for each field] +-- +-- [if value is NULL] +-- <-1: 4 bytes> +-- [else] +-- +-- bytes> +-- [end if] +-- [end for] +-- + unitOfSize 4 + let + each decoder = do + unitOfSize 4 + len <- sized 4 Decoding.int + if len == -1 then return Nothing else Just <$> sized len decoder + htraverse' each decoders + -- | A `FromColumnValue` constraint lifts the `FromValue` parser -- to a decoding of a @(Symbol, ColumnType)@ to a `Type`, -- decoding `Null`s to `Maybe`s. You should not define instances for diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index a7ca0af0..00bfba90 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -591,7 +591,7 @@ instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty) -- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same -- field names as the column AliasesOf of a `ColumnsType`. type family SameFields - (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType) + (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ty)]) :: Constraint where SameFields ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields]) From 7b65fb143ade54d326af088e3f5b9d90231d1559 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 11 Apr 2018 09:12:12 -0700 Subject: [PATCH 18/92] unshadow --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index d5e801a7..0375c9f2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -242,7 +242,7 @@ composite :: SListI ys => NP Decoding.Value ys -> Decoding.Value (NP Maybe ys) -composite decoders = do +composite fields = do -- [for each field] -- -- [if value is NULL] @@ -255,11 +255,11 @@ composite decoders = do -- unitOfSize 4 let - each decoder = do + each field = do unitOfSize 4 len <- sized 4 Decoding.int - if len == -1 then return Nothing else Just <$> sized len decoder - htraverse' each decoders + if len == -1 then return Nothing else Just <$> sized len field + htraverse' each fields -- | A `FromColumnValue` constraint lifts the `FromValue` parser -- to a decoding of a @(Symbol, ColumnType)@ to a `Type`, From 5677306b938befe2e61b12d0a62b1ceb702575c7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 11 Apr 2018 09:13:36 -0700 Subject: [PATCH 19/92] move decoder instance code for composite --- .../src/Squeal/PostgreSQL/Binary.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 0375c9f2..efb1b5cf 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -203,6 +203,14 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where fromValue _ = Decoding.array (Decoding.dimensionArray Vector.replicateM (Decoding.nullableValueArray (fromValue (Proxy @pg)))) +instance + ( SListI fields + , IsMaybes ys + , IsProductType y (Maybes ys) + , AllZip FromAliasedValue fields ys + , SameFields (DatatypeInfoOf y) fields + ) => FromValue ('PGcomposite fields) y where + fromValue = fmap (to . SOP . Z . maybes) . composite . decoders class IsMaybes (xs :: [Type]) where type family Maybes xs = (mxs :: [Type]) | mxs -> xs @@ -221,15 +229,6 @@ class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where instance FromValue pg y => FromAliasedValue (alias ::: pg) y where fromAliasedValue _ = fromValue (Proxy @pg) -instance - ( SListI fields - , IsMaybes ys - , IsProductType y (Maybes ys) - , AllZip FromAliasedValue fields ys - , SameFields (DatatypeInfoOf y) fields - ) => FromValue ('PGcomposite fields) y where - fromValue = fmap (to . SOP . Z . maybes) . composite . decoders - decoders :: forall pgs ys proxy . AllZip FromAliasedValue pgs ys From 0f3aa2f7841d54bd5d8990a1df0cbf220cb0f8fe Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 11 Apr 2018 19:23:25 -0700 Subject: [PATCH 20/92] create type safety --- squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index 5fe4e196..de803790 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -485,7 +485,7 @@ WITH statements -- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[] -- manipulation = with -- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil) --- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t))))) +-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t))))) -- in renderManipulation manipulation -- :} -- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\";" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 00bfba90..b9b03cee 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -545,6 +545,10 @@ type family Join xs ys where -- `Squeal.PostgreSQL.Definition.addColumn`. type family Create alias x xs where Create alias x '[] = '[alias ::: x] + Create alias x (alias ::: y ': xs) = TypeError + ('Text "Create: alias " + ':<>: 'ShowType alias + ':<>: 'Text "already in use") Create alias y (x ': xs) = x ': Create alias y xs -- | @Drop alias xs@ removes the type associated with @alias@ in @xs@ @@ -631,4 +635,4 @@ type family With :: SchemaType where With '[] schema = schema With (alias ::: rel ': rels) schema = - alias ::: 'Table ('[] :=> RelationToColumns rel) ': With rels schema + alias ::: 'View rel ': With rels schema From 3148d4119437c62c38e7cd66d488c0a6c3350b00 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 15 Apr 2018 21:32:29 -0600 Subject: [PATCH 21/92] enum decoding --- .../src/Squeal/PostgreSQL/Binary.hs | 17 +++++++++++++++++ .../src/Squeal/PostgreSQL/Schema.hs | 13 +++++++++++++ 2 files changed, 30 insertions(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index efb1b5cf..a7a721e3 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -46,6 +46,7 @@ module Squeal.PostgreSQL.Binary import BinaryParser import Data.Aeson hiding (Null) +import Data.Char (toUpper) import Data.Int import Data.Kind import Data.Scientific @@ -56,6 +57,7 @@ import Data.Word import Generics.SOP import GHC.TypeLits import Network.IP.Addr +import Text.Read (readMaybe) import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict hiding (unpack) @@ -203,6 +205,21 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where fromValue _ = Decoding.array (Decoding.dimensionArray Vector.replicateM (Decoding.nullableValueArray (fromValue (Proxy @pg)))) +instance + ( IsEnumType y + , Read y + -- , SameLabels (DatatypeInfoOf y) labels + -- + -- uncomment above constraint when GHC issue #11671 is fixed + -- Allow labels starting with uppercase with OverloadedLabels + -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8 + ) => FromValue ('PGenum labels) y where + fromValue _ = + let + upper "" = "" + upper (ch:chs) = toUpper ch : chs + in + Decoding.enum (readMaybe . upper . Strict.unpack) instance ( SListI fields , IsMaybes ys diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index b9b03cee..aa7f645a 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -99,6 +99,8 @@ module Squeal.PostgreSQL.Schema -- * Generics , SameField , SameFields + , SameLabel + , SameLabels -- * Schema , SchemumType (..) , SchemaType @@ -606,6 +608,17 @@ type family SameFields columns = SOP.AllZip SameField fields columns +class SameLabel + (constrInfo :: Type.ConstructorInfo) (label :: Symbol) where +instance name ~ label => SameLabel ('Type.Constructor name) label + +type family SameLabels + (datatypeInfo :: Type.DatatypeInfo) (labels :: [Symbol]) + :: Constraint where + SameLabels + ('Type.ADT _module _datatype constructors) labels + = SOP.AllZip SameLabel constructors labels + -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where ConstraintInvolves column ('Check columns) = column `Elem` columns From e7e969307c43355605f4288d957948b37e2c4f89 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 16 Apr 2018 17:01:37 -0600 Subject: [PATCH 22/92] enum and composite pieces * label - enum construction * row - composite construction * composite access * enum encoding --- .../src/Squeal/PostgreSQL/Binary.hs | 13 ++++++++-- .../src/Squeal/PostgreSQL/Expression.hs | 25 +++++++++++++++++++ 2 files changed, 36 insertions(+), 2 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index a7a721e3..bbb2c103 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -60,7 +60,7 @@ import Network.IP.Addr import Text.Read (readMaybe) import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString as Strict hiding (unpack) +import qualified Data.ByteString as Strict hiding (pack, unpack) import qualified Data.Text.Lazy as Lazy import qualified Data.Text as Strict import qualified Data.Vector as Vector @@ -123,7 +123,16 @@ instance (HasOid pg, ToParam x pg) => ToParam (Vector (Maybe x)) ('PGvararray pg) where toParam = K . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg) - +instance + ( IsEnumType x + , Show x + -- , SameLabels (DatatypeInfoOf y) labels + -- + -- uncomment above constraint when GHC issue #11671 is fixed + -- Allow labels starting with uppercase with OverloadedLabels + -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8 + ) => ToParam x ('PGenum labels) where + toParam = K . Encoding.text_strict . Strict.pack . show -- | A `ToColumnParam` constraint lifts the `ToParam` encoding -- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should -- not define instances of `ToColumnParam`, just use the provided instances. diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 5bbcceb4..3bad1b77 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -323,6 +323,31 @@ array array xs = UnsafeExpression $ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]" +label + :: (KnownSymbol label, label `In` labels) + => Alias label + -> Expression relations grouping params (nullity ('PGenum labels)) +label (_ :: Alias label) = UnsafeExpression $ + fromString $ symbolVal (Proxy @label) + +type family Nulls tys where + Nulls '[] = '[] + Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys + +row + :: (SListI (Nulls fields)) + => NP (Aliased (Expression relation grouping params)) (Nulls fields) + -> Expression relation grouping params (nullity ('PGcomposite fields)) +row exprs = UnsafeExpression $ "ROW" <> parenthesized + (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs) + +instance Has field fields ty => IsLabel field + ( Expression relation grouping params (nullity ('PGcomposite fields)) + -> Expression relation grouping params ('Null ty) ) where + fromLabel expr = UnsafeExpression $ + parenthesized (renderExpression expr) <> "." <> + fromString (symbolVal (Proxy @field)) + instance Monoid (Expression relations grouping params (nullity ('PGvararray ty))) where mempty = array [] From 3be316a547d4dffecaf22ef4558bebe28c69d78c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 17 Apr 2018 13:22:04 -0600 Subject: [PATCH 23/92] lots of stuff --- .../src/Squeal/PostgreSQL/Binary.hs | 80 +++++++---------- .../src/Squeal/PostgreSQL/Definition.hs | 4 - .../src/Squeal/PostgreSQL/Expression.hs | 14 +-- .../src/Squeal/PostgreSQL/Manipulation.hs | 86 +++++++++---------- .../src/Squeal/PostgreSQL/Migration.hs | 4 +- squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs | 7 +- .../src/Squeal/PostgreSQL/Pool.hs | 3 +- .../src/Squeal/PostgreSQL/Query.hs | 11 +-- .../src/Squeal/PostgreSQL/Render.hs | 1 - .../src/Squeal/PostgreSQL/Schema.hs | 67 ++++----------- .../src/Squeal/PostgreSQL/Transaction.hs | 9 +- 11 files changed, 97 insertions(+), 189 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index bbb2c103..827cf2c2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -9,10 +9,7 @@ Binary encoding and decoding between Haskell and PostgreSQL types. -} {-# LANGUAGE - ConstraintKinds - , DataKinds - , DefaultSignatures - , DeriveFoldable + DeriveFoldable , DeriveFunctor , DeriveGeneric , DeriveTraversable @@ -20,12 +17,9 @@ Binary encoding and decoding between Haskell and PostgreSQL types. , FlexibleInstances , GADTs , LambdaCase - , KindSignatures , MultiParamTypeClasses , ScopedTypeVariables , TypeApplications - , TypeFamilies - , TypeFamilyDependencies , TypeInType , TypeOperators , UndecidableInstances @@ -231,61 +225,47 @@ instance Decoding.enum (readMaybe . upper . Strict.unpack) instance ( SListI fields - , IsMaybes ys + , MapMaybes ys , IsProductType y (Maybes ys) , AllZip FromAliasedValue fields ys , SameFields (DatatypeInfoOf y) fields ) => FromValue ('PGcomposite fields) y where - fromValue = fmap (to . SOP . Z . maybes) . composite . decoders - -class IsMaybes (xs :: [Type]) where - type family Maybes xs = (mxs :: [Type]) | mxs -> xs - maybes :: NP Maybe xs -> NP I (Maybes xs) + fromValue = + let + decoders + :: forall pgs zs proxy + . AllZip FromAliasedValue pgs zs + => proxy ('PGcomposite pgs) + -> NP Decoding.Value zs + decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue + (hpure Proxy :: NP Proxy pgs) -instance IsMaybes '[] where - type Maybes '[] = '[] - maybes Nil = Nil + composite fields = do + -- [for each field] + -- + -- [if value is NULL] + -- <-1: 4 bytes> + -- [else] + -- + -- bytes> + -- [end if] + -- [end for] + -- + unitOfSize 4 + let + each field = do + unitOfSize 4 + len <- sized 4 Decoding.int + if len == -1 then return Nothing else Just <$> sized len field + htraverse' each fields -instance IsMaybes xs => IsMaybes (x ': xs) where - type Maybes (x ': xs) = Maybe x ': Maybes xs - maybes (x :* xs) = I x :* maybes xs + in fmap (to . SOP . Z . maybes) . composite . decoders class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where fromAliasedValue :: proxy pg -> Decoding.Value y instance FromValue pg y => FromAliasedValue (alias ::: pg) y where fromAliasedValue _ = fromValue (Proxy @pg) -decoders - :: forall pgs ys proxy - . AllZip FromAliasedValue pgs ys - => proxy ('PGcomposite pgs) - -> NP Decoding.Value ys -decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue - (hpure Proxy :: NP Proxy pgs) - -composite - :: SListI ys - => NP Decoding.Value ys - -> Decoding.Value (NP Maybe ys) -composite fields = do --- [for each field] --- --- [if value is NULL] --- <-1: 4 bytes> --- [else] --- --- bytes> --- [end if] --- [end for] --- - unitOfSize 4 - let - each field = do - unitOfSize 4 - len <- sized 4 Decoding.int - if len == -1 then return Nothing else Just <$> sized len field - htraverse' each fields - -- | A `FromColumnValue` constraint lifts the `FromValue` parser -- to a decoding of a @(Symbol, ColumnType)@ to a `Type`, -- decoding `Null`s to `Maybe`s. You should not define instances for diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 256b3bfd..c0ca08f7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -10,20 +10,16 @@ Squeal data definition language. {-# LANGUAGE ConstraintKinds - , DataKinds - , DeriveDataTypeable , DeriveGeneric , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving - , KindSignatures , LambdaCase , MultiParamTypeClasses , OverloadedStrings , RankNTypes , ScopedTypeVariables - , StandaloneDeriving , TypeApplications , TypeInType , TypeOperators diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 3bad1b77..8ac7f932 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -11,21 +11,15 @@ Squeal expressions are the atoms used to build statements. {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE AllowAmbiguousTypes - , DataKinds , DeriveGeneric - , DeriveDataTypeable , FlexibleContexts , FlexibleInstances , FunctionalDependencies - , GADTs , GeneralizedNewtypeDeriving , LambdaCase , MagicHash , OverloadedStrings - , PolyKinds - , RankNTypes , ScopedTypeVariables - , StandaloneDeriving , TypeApplications , TypeFamilies , TypeInType @@ -46,8 +40,10 @@ module Squeal.PostgreSQL.Expression , isn'tNull , matchNull , nullIf - -- ** Arrays + -- ** Arrays, Enums, Composites , array + , label + , row -- ** Functions , unsafeBinaryOp , unsafeUnaryOp @@ -330,10 +326,6 @@ label label (_ :: Alias label) = UnsafeExpression $ fromString $ symbolVal (Proxy @label) -type family Nulls tys where - Nulls '[] = '[] - Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys - row :: (SListI (Nulls fields)) => NP (Aliased (Expression relation grouping params)) (Nulls fields) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index de803790..a99856e7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -9,17 +9,13 @@ Squeal data manipulation language. -} {-# LANGUAGE - DataKinds - , DeriveDataTypeable - , DeriveGeneric + DeriveGeneric , FlexibleContexts , GADTs , GeneralizedNewtypeDeriving - , KindSignatures , LambdaCase , OverloadedStrings , RankNTypes - , StandaloneDeriving , TypeInType , TypeOperators #-} @@ -203,32 +199,32 @@ queryStatement q = UnsafeManipulation $ renderQuery q <> ";" INSERT statements -----------------------------------------} --- | Insert multiple rows. +-- | Insert multiple rws. -- -- When a table is created, it contains no data. The first thing to do -- before a database can be of much use is to insert data. Data is --- conceptually inserted one row at a time. Of course you can also insert --- more than one row, but there is no way to insert less than one row. --- Even if you know only some column values, a complete row must be created. +-- conceptually inserted one rw at a time. Of course you can also insert +-- more than one rw, but there is no way to insert less than one rw. +-- Even if you know only some column values, a complete rw must be created. insertRows :: ( SOP.SListI columns , SOP.SListI results , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert + -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rws to insert -> ConflictClause columns params -- ^ what to do in case of constraint conflict -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results -insertRows tab row rows conflict returning = UnsafeManipulation $ +insertRows tab rw rws conflict returning = UnsafeManipulation $ "INSERT" <+> "INTO" <+> renderAlias tab - <+> parenthesized (renderCommaSeparated renderAliasPart row) + <+> parenthesized (renderCommaSeparated renderAliasPart rw) <+> "VALUES" <+> commaSeparated ( parenthesized - . renderCommaSeparated renderColumnValuePart <$> row:rows ) + . renderCommaSeparated renderColumnValuePart <$> rw:rws ) <> renderConflictClause conflict <> renderReturningClause returning where @@ -239,41 +235,41 @@ insertRows tab row rows conflict returning = UnsafeManipulation $ Default -> "DEFAULT" Set expression -> renderExpression expression --- | Insert a single row. +-- | Insert a single rw. insertRow :: ( SOP.SListI columns , SOP.SListI results , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert -> ConflictClause columns params -- ^ what to do in case of constraint conflict -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results -insertRow tab row = insertRows tab row [] +insertRow tab rw = insertRows tab rw [] --- | Insert multiple rows returning `Nil` and raising an error on conflicts. +-- | Insert multiple rws returning `Nil` and raising an error on conflicts. insertRows_ :: ( SOP.SListI columns , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert + -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rws to insert -> Manipulation schema params '[] -insertRows_ tab row rows = - insertRows tab row rows OnConflictDoRaise (Returning Nil) +insertRows_ tab rw rws = + insertRows tab rw rws OnConflictDoRaise (Returning Nil) --- | Insert a single row returning `Nil` and raising an error on conflicts. +-- | Insert a single rw returning `Nil` and raising an error on conflicts. insertRow_ :: ( SOP.SListI columns , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert -> Manipulation schema params '[] -insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil) +insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil) -- | Insert a `Query`. insertQuery @@ -304,11 +300,11 @@ insertQuery_ insertQuery_ tab query = insertQuery tab query OnConflictDoRaise (Returning Nil) --- | `ColumnValue`s are values to insert or update in a row +-- | `ColumnValue`s are values to insert or update in a rw -- `Same` updates with the same value. -- `Default` inserts or updates with the @DEFAULT@ value -- `Set` a value to be an `Expression`, relative to the given --- row for an update, and closed for an insert. +-- rw for an update, and closed for an insert. data ColumnValue (columns :: RelationType) (params :: [NullityType]) @@ -321,14 +317,14 @@ data ColumnValue -> ColumnValue columns params (constraint :=> ty) -- | A `ReturningClause` computes and return value(s) based --- on each row actually inserted, updated or deleted. This is primarily +-- on each rw actually inserted, updated or deleted. This is primarily -- useful for obtaining values that were supplied by defaults, such as a -- serial sequence number. However, any expression using the table's columns --- is allowed. Only rows that were successfully inserted or updated or --- deleted will be returned. For example, if a row was locked +-- is allowed. Only rws that were successfully inserted or updated or +-- deleted will be returned. For example, if a rw was locked -- but not updated because an `OnConflictDoUpdate` condition was not satisfied, --- the row will not be returned. `ReturningStar` will return all columns --- in the row. Use @Returning Nil@ in the common case where no return +-- the rw will not be returned. `ReturningStar` will return all columns +-- in the rw. Use @Returning Nil@ in the common case where no return -- values are desired. data ReturningClause (columns :: ColumnsType) @@ -356,8 +352,8 @@ renderReturningClause = \case -- | A `ConflictClause` specifies an action to perform upon a constraint -- violation. `OnConflictDoRaise` will raise an error. --- `OnConflictDoNothing` simply avoids inserting a row. --- `OnConflictDoUpdate` updates the existing row that conflicts with the row +-- `OnConflictDoNothing` simply avoids inserting a rw. +-- `OnConflictDoUpdate` updates the existing rw that conflicts with the rw -- proposed for insertion. data ConflictClause (columns :: ColumnsType) params where OnConflictDoRaise :: ConflictClause columns params @@ -397,7 +393,7 @@ UPDATE statements -----------------------------------------} -- | An `update` command changes the values of the specified columns --- in all rows that satisfy the condition. +-- in all rws that satisfy the condition. update :: ( SOP.SListI columns , SOP.SListI results @@ -407,7 +403,7 @@ update -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to perform update on a row + -- ^ condition under which to perform update on a rw -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results update tab columns wh returning = UnsafeManipulation $ @@ -428,7 +424,7 @@ update tab columns wh returning = UnsafeManipulation $ Set expression `As` column -> Just $ renderAlias column <+> "=" <+> renderExpression expression --- | Update a row returning `Nil`. +-- | Update a rw returning `Nil`. update_ :: ( SOP.SListI columns , Has tab schema ('Table table) @@ -437,7 +433,7 @@ update_ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to perform update on a row + -- ^ condition under which to perform update on a rw -> Manipulation schema params '[] update_ tab columns wh = update tab columns wh (Returning Nil) @@ -445,14 +441,14 @@ update_ tab columns wh = update tab columns wh (Returning Nil) DELETE statements -----------------------------------------} --- | Delete rows of a table. +-- | Delete rws of a table. deleteFrom :: ( SOP.SListI results , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to delete a row + -- ^ condition under which to delete a rw -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results deleteFrom tab wh returning = UnsafeManipulation $ @@ -460,13 +456,13 @@ deleteFrom tab wh returning = UnsafeManipulation $ <+> "WHERE" <+> renderExpression wh <> renderReturningClause returning --- | Delete rows returning `Nil`. +-- | Delete rws returning `Nil`. deleteFrom_ :: ( Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to delete a row + -- ^ condition under which to delete a rw -> Manipulation schema params '[] deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil) @@ -484,11 +480,11 @@ WITH statements -- let -- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[] -- manipulation = with --- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil) --- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t))))) +-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rws :* Nil) +-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rws `As` #t))))) -- in renderManipulation manipulation -- :} --- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\";" +-- "WITH \"deleted_rws\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rws\" AS \"t\";" with :: SOP.SListI commons => NP (Aliased (Manipulation schema params)) commons diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 9db68b30..46a72688 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -90,9 +90,7 @@ Row 0 -} {-# LANGUAGE - ScopedTypeVariables - , OverloadedStrings - , DataKinds + DataKinds , GADTs , LambdaCase , PolyKinds diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs index 9c17ef1c..6f0ab0e5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs @@ -20,15 +20,10 @@ of executing Squeal commands. {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE - DataKinds - , DefaultSignatures + DefaultSignatures , FunctionalDependencies - , PolyKinds - , DeriveFunctor , FlexibleContexts , FlexibleInstances - , MagicHash - , MultiParamTypeClasses , OverloadedStrings , RankNTypes , ScopedTypeVariables diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs index 7e685180..f19bbad1 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs @@ -9,8 +9,7 @@ A `MonadPQ` for pooled connections. -} {-# LANGUAGE - DataKinds - , DeriveFunctor + DeriveFunctor , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index dfd2d206..8cd8cc4b 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -9,23 +9,14 @@ Squeal queries. -} {-# LANGUAGE - DataKinds - , DeriveDataTypeable - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances + DeriveGeneric , GADTs , GeneralizedNewtypeDeriving - , KindSignatures , LambdaCase - , MultiParamTypeClasses , OverloadedStrings - , ScopedTypeVariables , StandaloneDeriving - , TypeApplications , TypeInType , TypeOperators - , UndecidableInstances #-} module Squeal.PostgreSQL.Query diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs index d334f1b2..f20aba12 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs @@ -14,7 +14,6 @@ Rendering helper functions. , PolyKinds , RankNTypes , ScopedTypeVariables - , TypeApplications #-} module Squeal.PostgreSQL.Render diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index aa7f645a..9a3854db 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -11,23 +11,17 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds - , DataKinds , DeriveAnyClass - , DeriveDataTypeable , DeriveGeneric , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs - , MagicHash - , MultiParamTypeClasses , OverloadedStrings - , PolyKinds , RankNTypes - , ScopedTypeVariables , StandaloneDeriving , TypeApplications - , TypeFamilies + , TypeFamilyDependencies , TypeInType , TypeOperators , UndecidableInstances @@ -45,8 +39,6 @@ module Squeal.PostgreSQL.Schema , NilRelation , RelationsType , TableType - , TablesType - , NilTables -- * Grouping , Grouping (..) , GroupedBy @@ -92,8 +84,6 @@ module Squeal.PostgreSQL.Schema , ColumnsToRelation , RelationToColumns , TableToColumns - , TablesToRelations - , RelationsToTables , ConstraintInvolves , DropIfConstraintsInvolve -- * Generics @@ -101,6 +91,8 @@ module Squeal.PostgreSQL.Schema , SameFields , SameLabel , SameLabels + , MapMaybes (..) + , Nulls -- * Schema , SchemumType (..) , SchemaType @@ -109,11 +101,11 @@ module Squeal.PostgreSQL.Schema import Control.DeepSeq import Data.ByteString +import Data.Kind import Data.Monoid hiding (All) import Data.String import Data.Word import Data.Type.Bool -import GHC.Exts import GHC.OverloadedLabels import GHC.TypeLits @@ -279,31 +271,6 @@ type family Uniquely -- :} type TableType = (TableConstraints,ColumnsType) --- | `TablesType` is a row of `TableType`s, thought of as a union. --- --- >>> :{ --- type family Schema :: TablesType where --- Schema = --- '[ "users" ::: --- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2) --- ] --- , "emails" ::: --- '[ "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 --- ] --- ] --- :} -type TablesType = [(Symbol,TableType)] --- | A monokinded empty `TablesType`. -type family NilTables :: TablesType where NilTables = '[] - -- | `RelationType` is a row of `NullityType` -- -- >>> :{ @@ -337,18 +304,6 @@ type family RelationToColumns (relation :: RelationType) :: ColumnsType where type family TableToColumns (table :: TableType) :: ColumnsType where TableToColumns (constraints :=> columns) = columns --- | `TablesToRelations` removes both table and column constraints. -type family TablesToRelations (tables :: TablesType) :: RelationsType where - TablesToRelations '[] = '[] - TablesToRelations (alias ::: constraint :=> columns ': tables) = - alias ::: ColumnsToRelation columns ': TablesToRelations tables - --- | `RelationsToTables` adds both trivial table and column constraints. -type family RelationsToTables (tables :: RelationsType) :: TablesType where - RelationsToTables '[] = '[] - RelationsToTables (alias ::: columns ': relations) = - alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations - -- | `Grouping` is an auxiliary namespace, created by -- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used -- for typesafe aggregation @@ -619,6 +574,20 @@ type family SameLabels ('Type.ADT _module _datatype constructors) labels = SOP.AllZip SameLabel constructors labels +class MapMaybes xs where + type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs + maybes :: SOP.NP Maybe xs -> SOP.NP SOP.I (Maybes xs) +instance MapMaybes '[] where + type Maybes '[] = '[] + maybes SOP.Nil = SOP.Nil +instance MapMaybes xs => MapMaybes (x ': xs) where + type Maybes (x ': xs) = Maybe x ': Maybes xs + maybes (x SOP.:* xs) = SOP.I x SOP.:* maybes xs + +type family Nulls tys where + Nulls '[] = '[] + Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys + -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where ConstraintInvolves column ('Check columns) = column `Elem` columns diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs index ddda791a..4516c51c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs @@ -9,16 +9,9 @@ Squeal transaction control language. -} {-# LANGUAGE - DataKinds - , EmptyCase - , FlexibleContexts - , FlexibleInstances + FlexibleContexts , LambdaCase , OverloadedStrings - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeFamilies - , TypeInType #-} module Squeal.PostgreSQL.Transaction From 87d962c7817f1565d9f2f04bff26d30f6dd3fc90 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 25 Apr 2018 17:22:41 -0700 Subject: [PATCH 24/92] introduce PG labels just like aliases but instead of `Label`, `PGLabel` see #27 discussion --- .../src/Squeal/PostgreSQL/Binary.hs | 13 ++----------- .../src/Squeal/PostgreSQL/Definition.hs | 4 ++-- .../src/Squeal/PostgreSQL/Expression.hs | 11 ++++------- .../src/Squeal/PostgreSQL/Schema.hs | 19 +++++++++++++++++++ 4 files changed, 27 insertions(+), 20 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 827cf2c2..4001c53c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -211,18 +211,9 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where instance ( IsEnumType y , Read y - -- , SameLabels (DatatypeInfoOf y) labels - -- - -- uncomment above constraint when GHC issue #11671 is fixed - -- Allow labels starting with uppercase with OverloadedLabels - -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8 + , SameLabels (DatatypeInfoOf y) labels ) => FromValue ('PGenum labels) y where - fromValue _ = - let - upper "" = "" - upper (ch:chs) = toUpper ch : chs - in - Decoding.enum (readMaybe . upper . Strict.unpack) + fromValue _ = Decoding.enum (readMaybe . Strict.unpack) instance ( SListI fields , MapMaybes ys diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index c0ca08f7..ff1897de 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -783,11 +783,11 @@ dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" createTypeEnum :: (KnownSymbol enum, SOP.All KnownSymbol labels) => Alias enum - -> NP Alias labels + -> NP PGlabel labels -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) createTypeEnum enum labels = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> - parenthesized (commaSeparated (renderAliases labels)) <> ";" + parenthesized (commaSeparated (renderLabels labels)) <> ";" createType :: (KnownSymbol comp, SOP.SListI fields) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 8ac7f932..9c570eda 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -42,7 +42,6 @@ module Squeal.PostgreSQL.Expression , nullIf -- ** Arrays, Enums, Composites , array - , label , row -- ** Functions , unsafeBinaryOp @@ -319,12 +318,10 @@ array array xs = UnsafeExpression $ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]" -label - :: (KnownSymbol label, label `In` labels) - => Alias label - -> Expression relations grouping params (nullity ('PGenum labels)) -label (_ :: Alias label) = UnsafeExpression $ - fromString $ symbolVal (Proxy @label) +instance (KnownSymbol label, label `In` labels) => IsPGlabel label + (Expression relations grouping params (nullity ('PGenum labels))) where + label = UnsafeExpression $ + "\'" <> fromString (symbolVal (Proxy @label)) <> "\'" row :: (SListI (Nulls fields)) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 9a3854db..d9c22be2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -19,6 +19,7 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. , GADTs , OverloadedStrings , RankNTypes + , ScopedTypeVariables , StandaloneDeriving , TypeApplications , TypeFamilyDependencies @@ -93,6 +94,10 @@ module Squeal.PostgreSQL.Schema , SameLabels , MapMaybes (..) , Nulls + , IsPGlabel (..) + , PGlabel (..) + , renderLabel + , renderLabels -- * Schema , SchemumType (..) , SchemaType @@ -618,3 +623,17 @@ type family With With '[] schema = schema With (alias ::: rel ': rels) schema = alias ::: 'View rel ': With rels schema + +class IsPGlabel (label :: Symbol) expr where label :: expr +instance label ~ label' + => IsPGlabel label (PGlabel label') where label = PGlabel +data PGlabel (label :: Symbol) = PGlabel + +renderLabel :: KnownSymbol label => proxy label -> ByteString +renderLabel (_ :: proxy label) = + "\'" <> fromString (symbolVal (SOP.Proxy @label)) <> "\'" + +renderLabels + :: SOP.All KnownSymbol labels => SOP.NP PGlabel labels -> [ByteString] +renderLabels = SOP.hcollapse + . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderLabel) From 0f81c9ef1d0359e855373dbdae11f6587debebee Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 25 Apr 2018 17:25:58 -0700 Subject: [PATCH 25/92] fixes --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 1 - squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 4001c53c..c72aa52e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -40,7 +40,6 @@ module Squeal.PostgreSQL.Binary import BinaryParser import Data.Aeson hiding (Null) -import Data.Char (toUpper) import Data.Int import Data.Kind import Data.Scientific diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 9c570eda..9dbf7210 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -320,8 +320,7 @@ array xs = UnsafeExpression $ instance (KnownSymbol label, label `In` labels) => IsPGlabel label (Expression relations grouping params (nullity ('PGenum labels))) where - label = UnsafeExpression $ - "\'" <> fromString (symbolVal (Proxy @label)) <> "\'" + label = UnsafeExpression $ renderLabel (PGlabel @label) row :: (SListI (Nulls fields)) From d3bfaa5fc40f72b5e78437c835432f7154ef7426 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 25 Apr 2018 20:40:43 -0700 Subject: [PATCH 26/92] encode composites --- squeal-postgresql/squeal-postgresql.cabal | 1 + .../src/Squeal/PostgreSQL/Binary.hs | 74 ++++++++++++++++--- .../src/Squeal/PostgreSQL/Schema.hs | 3 + 3 files changed, 69 insertions(+), 9 deletions(-) diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index 8ee48e6a..fc9c228a 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -39,6 +39,7 @@ library aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 , binary-parser + , bytestring-strict-builder , bytestring >= 0.10.8.2 , deepseq >= 1.4.3.0 , generics-sop >= 0.3.2.0 diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index c72aa52e..f51d7da6 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -9,7 +9,8 @@ Binary encoding and decoding between Haskell and PostgreSQL types. -} {-# LANGUAGE - DeriveFoldable + AllowAmbiguousTypes + , DeriveFoldable , DeriveFunctor , DeriveGeneric , DeriveTraversable @@ -39,9 +40,11 @@ module Squeal.PostgreSQL.Binary ) where import BinaryParser +import ByteString.StrictBuilder import Data.Aeson hiding (Null) import Data.Int import Data.Kind +import Data.Monoid hiding (All) import Data.Scientific import Data.Time import Data.UUID.Types @@ -119,13 +122,66 @@ instance (HasOid pg, ToParam x pg) instance ( IsEnumType x , Show x - -- , SameLabels (DatatypeInfoOf y) labels - -- - -- uncomment above constraint when GHC issue #11671 is fixed - -- Allow labels starting with uppercase with OverloadedLabels - -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8 + , SameLabels (DatatypeInfoOf x) labels ) => ToParam x ('PGenum labels) where toParam = K . Encoding.text_strict . Strict.pack . show +instance + ( SListI fields + , MapMaybes xs + , IsProductType x (Maybes xs) + , AllZip ToAliasedParam xs fields + , SameFields (DatatypeInfoOf x) fields + , All HasAliasedOid fields + ) => ToParam x ('PGcomposite fields) where + toParam = + let + + encoders = htrans (Proxy @ToAliasedParam) toAliasedParam + + composite + :: All HasAliasedOid row + => NP (K (Maybe Encoding.Encoding)) row + -> K Encoding.Encoding ('PGcomposite row) + composite fields = K $ + -- + -- [for each field] + -- + -- [if value is NULL] + -- <-1: 4 bytes> + -- [else] + -- + -- bytes> + -- [end if] + -- [end for] + int32BE (fromIntegral (lengthSList (Proxy @xs))) <> + let + each + :: HasAliasedOid field + => K (Maybe Encoding.Encoding) field + -> Encoding.Encoding + each (K field :: K (Maybe Encoding.Encoding) field) = + word32BE (aliasedOid @field) + <> case field of + Nothing -> int64BE (-1) + Just value -> + int32BE (fromIntegral (builderLength value)) + <> value + in + hcfoldMap (Proxy @HasAliasedOid) each fields + + in + composite . encoders . unMaybes . unZ . unSOP . from + +class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32 +instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty + +class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where + toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field +instance ToParam x ty => ToAliasedParam x (alias ::: ty) where + toAliasedParam = \case + Nothing -> K Nothing + Just x -> K . Just . unK $ toParam @x @ty x + -- | A `ToColumnParam` constraint lifts the `ToParam` encoding -- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should -- not define instances of `ToColumnParam`, just use the provided instances. @@ -231,6 +287,7 @@ instance (hpure Proxy :: NP Proxy pgs) composite fields = do + -- -- [for each field] -- -- [if value is NULL] @@ -240,7 +297,6 @@ instance -- bytes> -- [end if] -- [end for] - -- unitOfSize 4 let each field = do @@ -274,10 +330,10 @@ instance FromValue pg y => FromColumnValue (column ::: ('NotNull pg)) y where fromColumnValue = \case K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL" - K (Just bytes) -> + K (Just bs) -> let errOrValue = - Decoding.valueParser (fromValue @pg @y Proxy) bytes + Decoding.valueParser (fromValue @pg @y Proxy) bs err str = error $ "fromColumnValue: " ++ Strict.unpack str in either err id errOrValue diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index d9c22be2..338634d5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -582,12 +582,15 @@ type family SameLabels class MapMaybes xs where type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs maybes :: SOP.NP Maybe xs -> SOP.NP SOP.I (Maybes xs) + unMaybes :: SOP.NP SOP.I (Maybes xs) -> SOP.NP Maybe xs instance MapMaybes '[] where type Maybes '[] = '[] maybes SOP.Nil = SOP.Nil + unMaybes SOP.Nil = SOP.Nil instance MapMaybes xs => MapMaybes (x ': xs) where type Maybes (x ': xs) = Maybe x ': Maybes xs maybes (x SOP.:* xs) = SOP.I x SOP.:* maybes xs + unMaybes (SOP.I mx SOP.:* xs) = mx SOP.:* unMaybes xs type family Nulls tys where Nulls '[] = '[] From 7018d90f3334c7ecdb9e554b12b69d12bae3e4d4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 26 Apr 2018 17:16:03 -0700 Subject: [PATCH 27/92] createTypeEnumFromHaskell createTypeEnumFromHaskell --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 2 +- .../src/Squeal/PostgreSQL/Definition.hs | 13 +++++++++++++ squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 13 +++++++++++++ 3 files changed, 27 insertions(+), 1 deletion(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index f51d7da6..d28f971a 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -313,7 +313,7 @@ instance FromValue pg y => FromAliasedValue (alias ::: pg) y where fromAliasedValue _ = fromValue (Proxy @pg) -- | A `FromColumnValue` constraint lifts the `FromValue` parser --- to a decoding of a @(Symbol, ColumnType)@ to a `Type`, +-- to a decoding of a @(Symbol, NullityType)@ to a `Type`, -- decoding `Null`s to `Maybe`s. You should not define instances for -- `FromColumnValue`, just use the provided instances. class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index ff1897de..50535617 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -66,6 +66,7 @@ module Squeal.PostgreSQL.Definition -- * Types , createType , createTypeEnum + , createTypeEnumFromHaskell , dropType , ColumnTypeExpression (..) , notNull @@ -789,6 +790,18 @@ createTypeEnum enum labels = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> parenthesized (commaSeparated (renderLabels labels)) <> ";" +createTypeEnumFromHaskell + :: forall enum labels hask proxy schema + . ( KnownSymbol enum + , SOP.All KnownSymbol labels + , SOP.IsEnumType hask + , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) ) + => Alias enum + -> proxy hask + -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) +createTypeEnumFromHaskell enum _ = createTypeEnum enum + (SOP.hpure label :: NP PGlabel labels) + createType :: (KnownSymbol comp, SOP.SListI fields) => Alias comp diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 338634d5..580d5ac0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -98,6 +98,9 @@ module Squeal.PostgreSQL.Schema , PGlabel (..) , renderLabel , renderLabels + , LabelOf + , LabelsOf + , DatatypeLabels -- * Schema , SchemumType (..) , SchemaType @@ -640,3 +643,13 @@ renderLabels :: SOP.All KnownSymbol labels => SOP.NP PGlabel labels -> [ByteString] renderLabels = SOP.hcollapse . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderLabel) + +type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where + LabelOf ('Type.Constructor name) = name + +type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where + LabelsOf '[] = '[] + LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss + +type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where + DatatypeLabels ('Type.ADT _module _datatype constructors) = LabelsOf constructors From c08a8a6a2433f36fa39ced0aa2901c0213151f5f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 18 May 2018 14:32:30 -0700 Subject: [PATCH 28/92] null_, notNull and values --- README.md | 2 +- squeal-postgresql/exe/Example.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL.hs | 2 +- .../src/Squeal/PostgreSQL/Definition.hs | 41 +++++++------- .../src/Squeal/PostgreSQL/Expression.hs | 54 ++++++++++--------- .../src/Squeal/PostgreSQL/Migration.hs | 2 +- .../src/Squeal/PostgreSQL/Query.hs | 20 +++++++ 7 files changed, 72 insertions(+), 51 deletions(-) diff --git a/README.md b/README.md index d9b20609..26069340 100644 --- a/README.md +++ b/README.md @@ -132,7 +132,7 @@ let createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* - (text & null') `As` #email :* Nil ) + (text & null_) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index 415bd4f0..466fb9fb 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -52,7 +52,7 @@ setup = createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* - (text & null') `As` #email :* Nil ) + (text & null_) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 2b5f34a6..89456eb4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -71,7 +71,7 @@ -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* --- (text & null') `As` #email :* Nil ) +-- (text & null_) `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 50535617..8523d508 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -69,8 +69,6 @@ module Squeal.PostgreSQL.Definition , createTypeEnumFromHaskell , dropType , ColumnTypeExpression (..) - , notNull - , null' , default_ , serial2 , smallserial @@ -122,7 +120,7 @@ CREATE statements -- >>> :set -XOverloadedLabels -- >>> :{ -- renderDefinition $ --- createTable #tab ((int & null') `As` #a :* (real & null') `As` #b :* Nil) Nil +-- createTable #tab ((int & null_) `As` #a :* (real & null_) `As` #b :* Nil) Nil -- :} -- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTable @@ -149,7 +147,7 @@ createTable tab columns constraints = UnsafeDefinition $ -- >>> type Schema = '["tab" ::: 'Table Table] -- >>> :{ -- renderDefinition --- (createTableIfNotExists #tab ((int & null') `As` #a :* (real & null') `As` #b :* Nil) Nil :: Definition Schema Schema) +-- (createTableIfNotExists #tab ((int & null_) `As` #a :* (real & null_) `As` #b :* Nil) Nil :: Definition Schema Schema) -- :} -- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTableIfNotExists @@ -262,8 +260,8 @@ check _cols condition = UnsafeTableConstraintExpression $ -- let -- definition :: Definition '[] Schema -- definition = createTable #tab --- ( (int & null') `As` #a :* --- (int & null') `As` #b :* Nil ) +-- ( (int & null_) `As` #a :* +-- (int & null_) `As` #b :* Nil ) -- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) -- :} -- @@ -343,7 +341,7 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- createTable #emails -- ( serial `As` #id :* -- (int & notNull) `As` #user_id :* --- (text & null') `As` #email :* Nil ) +-- (text & null_) `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) @@ -373,7 +371,7 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- createTable #employees -- ( serial `As` #id :* -- (text & notNull) `As` #name :* --- (integer & null') `As` #employer_id :* Nil ) +-- (integer & null_) `As` #employer_id :* Nil ) -- ( primaryKey #id `As` #employees_pk :* -- foreignKey #employer_id #employees #id -- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) @@ -575,7 +573,7 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & null' & default_ "foo")) + -- definition = alterTable #tab (addColumn #col2 (text & null_ & default_ "foo")) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL DEFAULT E'foo';" @@ -587,7 +585,7 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & null')) + -- definition = alterTable #tab (addColumn #col2 (text & null_)) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL;" @@ -826,17 +824,18 @@ instance (Has alias schema ('Typedef ty)) => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias)) -null' - :: TypeExpression ty - -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) -null' ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" - --- | used in `createTable` commands as a column constraint to ensure --- @NULL@ is not present -notNull - :: TypeExpression ty - -> ColumnTypeExpression schema (def :=> 'NotNull ty) -notNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" +instance HasNull + ( TypeExpression ty + -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) ) where + null_ ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" + +instance HasNotNull + ( TypeExpression ty + -> + ColumnTypeExpression schema (def :=> 'NotNull ty) ) where + -- | used in `createTable` commands as a column constraint to ensure + -- @NULL@ is not present + notNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" -- | used in `createTable` commands as a column constraint to give a default default_ diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 9dbf7210..b76d8b69 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -32,8 +32,8 @@ module Squeal.PostgreSQL.Expression Expression (UnsafeExpression, renderExpression) , HasParameter (param) -- ** Null - , null_ - , unNull + , HasNull (null_) + , HasNotNull (notNull) , coalesce , fromNull , isNull @@ -221,26 +221,28 @@ instance relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column --- | analagous to `Nothing` --- --- >>> renderExpression $ null_ --- "NULL" -null_ :: Expression relations grouping params ('Null ty) -null_ = UnsafeExpression "NULL" - --- | analagous to `Just` --- --- >>> renderExpression $ unNull true --- "TRUE" -unNull - :: Expression relations grouping params ('NotNull ty) - -- ^ not @NULL@ - -> Expression relations grouping params ('Null ty) -unNull = UnsafeExpression . renderExpression +class HasNull expr where null_ :: expr +instance HasNull (Expression rels grouping params ('Null ty)) where + -- | analagous to `Nothing` + -- + -- >>> renderExpression $ null_ + -- "NULL" + null_ = UnsafeExpression "NULL" + +class HasNotNull expr where notNull :: expr +instance HasNotNull + ( Expression rels grouping params ('NotNull ty) + -> + Expression rels grouping params ('Null ty) ) where + -- | analagous to `Just` + -- + -- >>> renderExpression $ notNull true + -- "TRUE" + notNull = UnsafeExpression . renderExpression -- | return the leftmost value which is not NULL -- --- >>> renderExpression $ coalesce [null_, unNull true] false +-- >>> renderExpression $ coalesce [null_, notNull true] false -- "COALESCE(NULL, TRUE, FALSE)" coalesce :: [Expression relations grouping params ('Null ty)] @@ -309,7 +311,7 @@ nullIf nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized (renderExpression x <> ", " <> renderExpression y) --- | >>> renderExpression $ array [null_, unNull false, unNull true] +-- | >>> renderExpression $ array [null_, notNull false, notNull true] -- "ARRAY[NULL, FALSE, TRUE]" array :: [Expression relations grouping params ('Null ty)] @@ -628,7 +630,7 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=` -- will produce @NULL@s if one of their arguments is @NULL@. -- --- >>> renderExpression $ unNull true .== null_ +-- >>> renderExpression $ notNull true .== null_ -- "(TRUE = NULL)" (.==) :: Expression relations grouping params (nullity ty) -- ^ lhs @@ -637,7 +639,7 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ (.==) = unsafeBinaryOp "=" infix 4 .== --- | >>> renderExpression $ unNull true ./= null_ +-- | >>> renderExpression $ notNull true ./= null_ -- "(TRUE <> NULL)" (./=) :: Expression relations grouping params (nullity ty) -- ^ lhs @@ -646,7 +648,7 @@ infix 4 .== (./=) = unsafeBinaryOp "<>" infix 4 ./= --- | >>> renderExpression $ unNull true .>= null_ +-- | >>> renderExpression $ notNull true .>= null_ -- "(TRUE >= NULL)" (.>=) :: Expression relations grouping params (nullity ty) -- ^ lhs @@ -655,7 +657,7 @@ infix 4 ./= (.>=) = unsafeBinaryOp ">=" infix 4 .>= --- | >>> renderExpression $ unNull true .< null_ +-- | >>> renderExpression $ notNull true .< null_ -- "(TRUE < NULL)" (.<) :: Expression relations grouping params (nullity ty) -- ^ lhs @@ -664,7 +666,7 @@ infix 4 .>= (.<) = unsafeBinaryOp "<" infix 4 .< --- | >>> renderExpression $ unNull true .<= null_ +-- | >>> renderExpression $ notNull true .<= null_ -- "(TRUE <= NULL)" (.<=) :: Expression relations grouping params (nullity ty) -- ^ lhs @@ -673,7 +675,7 @@ infix 4 .< (.<=) = unsafeBinaryOp "<=" infix 4 .<= --- | >>> renderExpression $ unNull true .> null_ +-- | >>> renderExpression $ notNull true .> null_ -- "(TRUE > NULL)" (.>) :: Expression relations grouping params (nullity ty) -- ^ lhs diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 46a72688..4f6dceb8 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -53,7 +53,7 @@ let createTable #emails ( serial `As` #id :* (int & notNull) `As` #user_id :* - (text & null') `As` #email :* Nil ) + (text & null_) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 8cd8cc4b..a76bbf3c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -35,6 +35,7 @@ module Squeal.PostgreSQL.Query , selectDistinctStar , selectDotStar , selectDistinctDotStar + , values -- * Table Expressions , TableExpression (..) , renderTableExpression @@ -424,6 +425,25 @@ selectDistinctDotStar rel relations = UnsafeQuery $ "SELECT DISTINCT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations +values + :: SListI cols + => NP (Aliased (Expression '[] 'Ungrouped params)) cols + -> [NP (Aliased (Expression '[] 'Ungrouped params)) cols] + -> Query schema params cols +values rw rws = UnsafeQuery $ "SELECT * FROM" + <+> parenthesized ( + "VALUES" + <+> commaSeparated + ( parenthesized + . renderCommaSeparated renderValuePart <$> rw:rws ) + ) <+> "AS t" + <+> parenthesized (renderCommaSeparated renderAliasPart rw) + where + renderAliasPart, renderValuePart + :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString + renderAliasPart (_ `As` name) = renderAlias name + renderValuePart (value `As` _) = renderExpression value + {----------------------------------------- Table Expressions -----------------------------------------} From 5b9374fa4c7a2b19bff80152ef25e5fde63cb34e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 18 May 2018 19:54:26 -0700 Subject: [PATCH 29/92] semigroup --- .../src/Squeal/PostgreSQL/Expression.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index b76d8b69..fae59bf3 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -138,7 +138,7 @@ import Control.Category import Control.DeepSeq import Data.ByteString (ByteString) import Data.Function ((&)) -import Data.Monoid hiding (All) +import Data.Semigroup import Data.Ratio import Data.String import Generics.SOP hiding (from) @@ -338,10 +338,14 @@ instance Has field fields ty => IsLabel field parenthesized (renderExpression expr) <> "." <> fromString (symbolVal (Proxy @field)) +instance Semigroup + (Expression relations grouping params (nullity ('PGvararray ty))) where + (<>) = unsafeBinaryOp "||" + instance Monoid (Expression relations grouping params (nullity ('PGvararray ty))) where mempty = array [] - mappend = unsafeBinaryOp "||" + mappend = (<>) -- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1] -- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))" @@ -734,10 +738,14 @@ instance IsString '\\' -> "\\\\" c -> [c] +instance Semigroup + (Expression relations grouping params (nullity 'PGtext)) where + (<>) = unsafeBinaryOp "||" + instance Monoid (Expression relations grouping params (nullity 'PGtext)) where mempty = fromString "" - mappend = unsafeBinaryOp "||" + mappend = (<>) -- | >>> renderExpression $ lower "ARRRGGG" -- "lower(E'ARRRGGG')" From e538877eab53baec31258fa2bf9ffd7182974579 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 18 May 2018 19:56:00 -0700 Subject: [PATCH 30/92] generic constructor --- .../src/Squeal/PostgreSQL/Binary.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index d28f971a..51245b01 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -121,10 +121,23 @@ instance (HasOid pg, ToParam x pg) (oid @pg) (unK . toParam @x @pg) instance ( IsEnumType x - , Show x + , HasDatatypeInfo x , SameLabels (DatatypeInfoOf x) labels ) => ToParam x ('PGenum labels) where - toParam = K . Encoding.text_strict . Strict.pack . show + toParam = + let + gcons :: forall y. (HasDatatypeInfo y, Generic y) => y -> String + gcons = gconstructor (constructorInfo (datatypeInfo (Proxy @y))) . from + + gconstructor :: NP ConstructorInfo xs -> SOP I xs -> String + gconstructor Nil _ = "" + gconstructor (Constructor name :* _) (SOP (Z _)) = name + gconstructor (Infix name _ _ :* _) (SOP (Z _)) = name + gconstructor (Record name _ :* _) (SOP (Z _)) = name + gconstructor (_ :* constructors) (SOP (S xs)) = + gconstructor constructors (SOP xs) + in + K . Encoding.text_strict . Strict.pack . gcons instance ( SListI fields , MapMaybes xs From 0df15eae8d9fdc39ffa401d79be8a78b7ea4822e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 18 May 2018 20:57:02 -0700 Subject: [PATCH 31/92] use generics for reading and showing enums --- .../src/Squeal/PostgreSQL/Binary.hs | 43 +++++++++++++------ 1 file changed, 29 insertions(+), 14 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 51245b01..0190249e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -53,7 +53,6 @@ import Data.Word import Generics.SOP import GHC.TypeLits import Network.IP.Addr -import Text.Read (readMaybe) import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict hiding (pack, unpack) @@ -126,18 +125,17 @@ instance ) => ToParam x ('PGenum labels) where toParam = let - gcons :: forall y. (HasDatatypeInfo y, Generic y) => y -> String - gcons = gconstructor (constructorInfo (datatypeInfo (Proxy @y))) . from - - gconstructor :: NP ConstructorInfo xs -> SOP I xs -> String - gconstructor Nil _ = "" - gconstructor (Constructor name :* _) (SOP (Z _)) = name - gconstructor (Infix name _ _ :* _) (SOP (Z _)) = name - gconstructor (Record name _ :* _) (SOP (Z _)) = name - gconstructor (_ :* constructors) (SOP (S xs)) = - gconstructor constructors (SOP xs) + gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String + gshowConstructor Nil _ = "" + gshowConstructor (constructor :* _) (SOP (Z _)) = + constructorName constructor + gshowConstructor (_ :* constructors) (SOP (S xs)) = + gshowConstructor constructors (SOP xs) in - K . Encoding.text_strict . Strict.pack . gcons + K . Encoding.text_strict + . Strict.pack + . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x))) + . from instance ( SListI fields , MapMaybes xs @@ -278,10 +276,27 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where (Decoding.nullableValueArray (fromValue (Proxy @pg)))) instance ( IsEnumType y - , Read y + , HasDatatypeInfo y , SameLabels (DatatypeInfoOf y) labels ) => FromValue ('PGenum labels) y where - fromValue _ = Decoding.enum (readMaybe . Strict.unpack) + fromValue _ = + let + greadConstructor + :: All ((~) '[]) xss + => NP ConstructorInfo xss + -> String + -> Maybe (SOP I xss) + greadConstructor Nil _ = Nothing + greadConstructor (constructor :* constructors) name = + if name == constructorName constructor + then Just (SOP (Z Nil)) + else SOP . S . unSOP <$> greadConstructor constructors name + in + Decoding.enum + $ fmap to + . greadConstructor (constructorInfo (datatypeInfo (Proxy @y))) + . Strict.unpack + instance ( SListI fields , MapMaybes ys From a646215c894d06120fee35ede915fad5fa0bf5c2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 18 May 2018 21:11:57 -0700 Subject: [PATCH 32/92] nulls --- README.md | 6 +- squeal-postgresql/exe/Example.hs | 8 +-- squeal-postgresql/src/Squeal/PostgreSQL.hs | 6 +- .../src/Squeal/PostgreSQL/Definition.hs | 55 ++++++++++--------- .../src/Squeal/PostgreSQL/Expression.hs | 45 +++++++-------- .../src/Squeal/PostgreSQL/Migration.hs | 10 ++-- 6 files changed, 64 insertions(+), 66 deletions(-) diff --git a/README.md b/README.md index 26069340..e2bda24c 100644 --- a/README.md +++ b/README.md @@ -127,12 +127,12 @@ let setup = createTable #users ( serial `As` #id :* - (text & notNull) `As` #name :* Nil ) + (text & hasNotNull) `As` #name :* Nil ) ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* - (int & notNull) `As` #user_id :* - (text & null_) `As` #email :* Nil ) + (int & hasNotNull) `As` #user_id :* + (text & hasNull) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index 466fb9fb..051592d3 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -45,14 +45,14 @@ setup :: Definition '[] Schema setup = createTable #users ( serial `As` #id :* - (text & notNull) `As` #name :* - (vararray int2 & notNull) `As` #vec :* Nil ) + (text & hasNotNull) `As` #name :* + (vararray int2 & hasNotNull) `As` #vec :* Nil ) ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* - (int & notNull) `As` #user_id :* - (text & null_) `As` #email :* Nil ) + (int & hasNotNull) `As` #user_id :* + (text & hasNull) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 89456eb4..39b30f71 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -66,12 +66,12 @@ -- setup = -- createTable #users -- ( serial `As` #id :* --- (text & notNull) `As` #name :* Nil ) +-- (text & hasNotNull) `As` #name :* Nil ) -- ( primaryKey #id `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* --- (int & notNull) `As` #user_id :* --- (text & null_) `As` #email :* Nil ) +-- (int & hasNotNull) `As` #user_id :* +-- (text & hasNull) `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 8523d508..ff78b133 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -69,6 +69,8 @@ module Squeal.PostgreSQL.Definition , createTypeEnumFromHaskell , dropType , ColumnTypeExpression (..) + , hasNull + , hasNotNull , default_ , serial2 , smallserial @@ -120,7 +122,7 @@ CREATE statements -- >>> :set -XOverloadedLabels -- >>> :{ -- renderDefinition $ --- createTable #tab ((int & null_) `As` #a :* (real & null_) `As` #b :* Nil) Nil +-- createTable #tab ((int & hasNull) `As` #a :* (real & hasNull) `As` #b :* Nil) Nil -- :} -- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTable @@ -147,7 +149,7 @@ createTable tab columns constraints = UnsafeDefinition $ -- >>> type Schema = '["tab" ::: 'Table Table] -- >>> :{ -- renderDefinition --- (createTableIfNotExists #tab ((int & null_) `As` #a :* (real & null_) `As` #b :* Nil) Nil :: Definition Schema Schema) +-- (createTableIfNotExists #tab ((int & hasNull) `As` #a :* (real & hasNull) `As` #b :* Nil) Nil :: Definition Schema Schema) -- :} -- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTableIfNotExists @@ -229,8 +231,8 @@ newtype TableConstraintExpression -- let -- definition :: Definition '[] Schema -- definition = createTable #tab --- ( (int & notNull) `As` #a :* --- (int & notNull) `As` #b :* Nil ) +-- ( (int & hasNotNull) `As` #a :* +-- (int & hasNotNull) `As` #b :* Nil ) -- ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) -- :} -- @@ -260,8 +262,8 @@ check _cols condition = UnsafeTableConstraintExpression $ -- let -- definition :: Definition '[] Schema -- definition = createTable #tab --- ( (int & null_) `As` #a :* --- (int & null_) `As` #b :* Nil ) +-- ( (int & hasNull) `As` #a :* +-- (int & hasNull) `As` #b :* Nil ) -- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) -- :} -- @@ -292,7 +294,7 @@ unique columns = UnsafeTableConstraintExpression $ -- definition :: Definition '[] Schema -- definition = createTable #tab -- ( serial `As` #id :* --- (text & notNull) `As` #name :* Nil ) +-- (text & hasNotNull) `As` #name :* Nil ) -- ( primaryKey #id `As` #pk_id :* Nil ) -- :} -- @@ -336,12 +338,12 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- setup = -- createTable #users -- ( serial `As` #id :* --- (text & notNull) `As` #name :* Nil ) +-- (text & hasNotNull) `As` #name :* Nil ) -- ( primaryKey #id `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* --- (int & notNull) `As` #user_id :* --- (text & null_) `As` #email :* Nil ) +-- (int & hasNotNull) `As` #user_id :* +-- (text & hasNull) `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) @@ -370,8 +372,8 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- setup = -- createTable #employees -- ( serial `As` #id :* --- (text & notNull) `As` #name :* --- (integer & null_) `As` #employer_id :* Nil ) +-- (text & hasNotNull) `As` #name :* +-- (integer & hasNull) `As` #employer_id :* Nil ) -- ( primaryKey #id `As` #employees_pk :* -- foreignKey #employer_id #employees #id -- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) @@ -573,7 +575,7 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & null_ & default_ "foo")) + -- definition = alterTable #tab (addColumn #col2 (text & hasNull & default_ "foo")) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL DEFAULT E'foo';" @@ -585,7 +587,7 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & null_)) + -- definition = alterTable #tab (addColumn #col2 (text & hasNull)) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL;" @@ -744,7 +746,7 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])] -- definition = --- alterTable #tab (alterColumn #col (alterType (numeric & notNull))) +-- alterTable #tab (alterColumn #col (alterType (numeric & hasNotNull))) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;" @@ -824,18 +826,17 @@ instance (Has alias schema ('Typedef ty)) => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias)) -instance HasNull - ( TypeExpression ty - -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) ) where - null_ ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" - -instance HasNotNull - ( TypeExpression ty - -> - ColumnTypeExpression schema (def :=> 'NotNull ty) ) where - -- | used in `createTable` commands as a column constraint to ensure - -- @NULL@ is not present - notNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" +hasNull + :: TypeExpression ty + -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) +hasNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" + +-- | used in `createTable` commands as a column constraint to ensure +-- @NULL@ is not present +hasNotNull + :: TypeExpression ty + -> ColumnTypeExpression schema (def :=> 'NotNull ty) +hasNotNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" -- | used in `createTable` commands as a column constraint to give a default default_ diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index fae59bf3..0bf18436 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -32,12 +32,12 @@ module Squeal.PostgreSQL.Expression Expression (UnsafeExpression, renderExpression) , HasParameter (param) -- ** Null - , HasNull (null_) - , HasNotNull (notNull) + , null_ + , notNull , coalesce , fromNull , isNull - , isn'tNull + , isNotNull , matchNull , nullIf -- ** Arrays, Enums, Composites @@ -221,24 +221,21 @@ instance relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column -class HasNull expr where null_ :: expr -instance HasNull (Expression rels grouping params ('Null ty)) where - -- | analagous to `Nothing` - -- - -- >>> renderExpression $ null_ - -- "NULL" - null_ = UnsafeExpression "NULL" - -class HasNotNull expr where notNull :: expr -instance HasNotNull - ( Expression rels grouping params ('NotNull ty) - -> - Expression rels grouping params ('Null ty) ) where - -- | analagous to `Just` - -- - -- >>> renderExpression $ notNull true - -- "TRUE" - notNull = UnsafeExpression . renderExpression +-- | analagous to `Nothing` +-- +-- >>> renderExpression $ null_ +-- "NULL" +null_ :: Expression rels grouping params ('Null ty) +null_ = UnsafeExpression "NULL" + +-- | analagous to `Just` +-- +-- >>> renderExpression $ notNull true +-- "TRUE" +notNull + :: Expression rels grouping params ('NotNull ty) + -> Expression rels grouping params ('Null ty) +notNull = UnsafeExpression . renderExpression -- | return the leftmost value which is not NULL -- @@ -273,13 +270,13 @@ isNull -> Condition relations grouping params isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL" --- | >>> renderExpression $ null_ & isn'tNull +-- | >>> renderExpression $ null_ & isNotNull -- "NULL IS NOT NULL" -isn'tNull +isNotNull :: Expression relations grouping params ('Null ty) -- ^ possibly @NULL@ -> Condition relations grouping params -isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" +isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@ -- diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 4f6dceb8..252ce99e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -37,7 +37,7 @@ let , up = void . define $ createTable #users ( serial `As` #id :* - (text & notNull) `As` #name :* Nil ) + (text & hasNotNull) `As` #name :* Nil ) ( primaryKey #id `As` #pk_users :* Nil ) , down = void . define $ dropTable #users } @@ -52,8 +52,8 @@ let , up = void . define $ createTable #emails ( serial `As` #id :* - (int & notNull) `As` #user_id :* - (text & null_) `As` #email :* Nil ) + (int & hasNotNull) `As` #user_id :* + (text & hasNull) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) @@ -285,8 +285,8 @@ createMigrations => Definition schema schema createMigrations = createTableIfNotExists #schema_migrations - ( (text & notNull) `As` #name :* - (timestampWithTimeZone & notNull & default_ currentTimestamp) + ( (text & hasNotNull) `As` #name :* + (timestampWithTimeZone & hasNotNull & default_ currentTimestamp) `As` #executed_at :* Nil ) ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil ) From bd505af5aa2258da22ba9862d19c041898bbd16e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 29 May 2018 10:32:45 -0700 Subject: [PATCH 33/92] fix docs rw ~> row --- .../src/Squeal/PostgreSQL/Manipulation.hs | 66 +++++++++---------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index a99856e7..a052d643 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -199,21 +199,21 @@ queryStatement q = UnsafeManipulation $ renderQuery q <> ";" INSERT statements -----------------------------------------} --- | Insert multiple rws. +-- | Insert multiple rows. -- -- When a table is created, it contains no data. The first thing to do -- before a database can be of much use is to insert data. Data is --- conceptually inserted one rw at a time. Of course you can also insert --- more than one rw, but there is no way to insert less than one rw. --- Even if you know only some column values, a complete rw must be created. +-- conceptually inserted one row at a time. Of course you can also insert +-- more than one row, but there is no way to insert less than one row. +-- Even if you know only some column values, a complete row must be created. insertRows :: ( SOP.SListI columns , SOP.SListI results , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rws to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert + -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert -> ConflictClause columns params -- ^ what to do in case of constraint conflict -> ReturningClause columns params results -- ^ results to return @@ -235,39 +235,39 @@ insertRows tab rw rws conflict returning = UnsafeManipulation $ Default -> "DEFAULT" Set expression -> renderExpression expression --- | Insert a single rw. +-- | Insert a single row. insertRow :: ( SOP.SListI columns , SOP.SListI results , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert -> ConflictClause columns params -- ^ what to do in case of constraint conflict -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results insertRow tab rw = insertRows tab rw [] --- | Insert multiple rws returning `Nil` and raising an error on conflicts. +-- | Insert multiple rows returning `Nil` and raising an error on conflicts. insertRows_ :: ( SOP.SListI columns , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rws to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert + -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert -> Manipulation schema params '[] insertRows_ tab rw rws = insertRows tab rw rws OnConflictDoRaise (Returning Nil) --- | Insert a single rw returning `Nil` and raising an error on conflicts. +-- | Insert a single row returning `Nil` and raising an error on conflicts. insertRow_ :: ( SOP.SListI columns , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ rw to insert + -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert -> Manipulation schema params '[] insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil) @@ -300,11 +300,11 @@ insertQuery_ insertQuery_ tab query = insertQuery tab query OnConflictDoRaise (Returning Nil) --- | `ColumnValue`s are values to insert or update in a rw +-- | `ColumnValue`s are values to insert or update in a row -- `Same` updates with the same value. -- `Default` inserts or updates with the @DEFAULT@ value -- `Set` a value to be an `Expression`, relative to the given --- rw for an update, and closed for an insert. +-- row for an update, and closed for an insert. data ColumnValue (columns :: RelationType) (params :: [NullityType]) @@ -317,14 +317,14 @@ data ColumnValue -> ColumnValue columns params (constraint :=> ty) -- | A `ReturningClause` computes and return value(s) based --- on each rw actually inserted, updated or deleted. This is primarily +-- on each row actually inserted, updated or deleted. This is primarily -- useful for obtaining values that were supplied by defaults, such as a -- serial sequence number. However, any expression using the table's columns --- is allowed. Only rws that were successfully inserted or updated or --- deleted will be returned. For example, if a rw was locked +-- is allowed. Only rows that were successfully inserted or updated or +-- deleted will be returned. For example, if a row was locked -- but not updated because an `OnConflictDoUpdate` condition was not satisfied, --- the rw will not be returned. `ReturningStar` will return all columns --- in the rw. Use @Returning Nil@ in the common case where no return +-- the row will not be returned. `ReturningStar` will return all columns +-- in the row. Use @Returning Nil@ in the common case where no return -- values are desired. data ReturningClause (columns :: ColumnsType) @@ -352,8 +352,8 @@ renderReturningClause = \case -- | A `ConflictClause` specifies an action to perform upon a constraint -- violation. `OnConflictDoRaise` will raise an error. --- `OnConflictDoNothing` simply avoids inserting a rw. --- `OnConflictDoUpdate` updates the existing rw that conflicts with the rw +-- `OnConflictDoNothing` simply avoids inserting a row. +-- `OnConflictDoUpdate` updates the existing row that conflicts with the row -- proposed for insertion. data ConflictClause (columns :: ColumnsType) params where OnConflictDoRaise :: ConflictClause columns params @@ -393,7 +393,7 @@ UPDATE statements -----------------------------------------} -- | An `update` command changes the values of the specified columns --- in all rws that satisfy the condition. +-- in all rows that satisfy the condition. update :: ( SOP.SListI columns , SOP.SListI results @@ -403,7 +403,7 @@ update -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to perform update on a rw + -- ^ condition under which to perform update on a row -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results update tab columns wh returning = UnsafeManipulation $ @@ -424,7 +424,7 @@ update tab columns wh returning = UnsafeManipulation $ Set expression `As` column -> Just $ renderAlias column <+> "=" <+> renderExpression expression --- | Update a rw returning `Nil`. +-- | Update a row returning `Nil`. update_ :: ( SOP.SListI columns , Has tab schema ('Table table) @@ -433,7 +433,7 @@ update_ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to perform update on a rw + -- ^ condition under which to perform update on a row -> Manipulation schema params '[] update_ tab columns wh = update tab columns wh (Returning Nil) @@ -441,14 +441,14 @@ update_ tab columns wh = update tab columns wh (Returning Nil) DELETE statements -----------------------------------------} --- | Delete rws of a table. +-- | Delete rows of a table. deleteFrom :: ( SOP.SListI results , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to delete a rw + -- ^ condition under which to delete a row -> ReturningClause columns params results -- ^ results to return -> Manipulation schema params results deleteFrom tab wh returning = UnsafeManipulation $ @@ -456,13 +456,13 @@ deleteFrom tab wh returning = UnsafeManipulation $ <+> "WHERE" <+> renderExpression wh <> renderReturningClause returning --- | Delete rws returning `Nil`. +-- | Delete rows returning `Nil`. deleteFrom_ :: ( Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params - -- ^ condition under which to delete a rw + -- ^ condition under which to delete a row -> Manipulation schema params '[] deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil) @@ -480,11 +480,11 @@ WITH statements -- let -- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[] -- manipulation = with --- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rws :* Nil) --- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rws `As` #t))))) +-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil) +-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t))))) -- in renderManipulation manipulation -- :} --- "WITH \"deleted_rws\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rws\" AS \"t\";" +-- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\";" with :: SOP.SListI commons => NP (Aliased (Manipulation schema params)) commons From 6d0dd7eb86cf624548cdcefb00fc40cb90db8371 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 29 May 2018 10:37:47 -0700 Subject: [PATCH 34/92] remove `;` from manipulations for composability of manipulations e.g. in WITH statements --- squeal-postgresql/src/Squeal/PostgreSQL.hs | 4 +-- .../src/Squeal/PostgreSQL/Manipulation.hs | 32 ++++++++----------- squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs | 3 +- 3 files changed, 17 insertions(+), 22 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 39b30f71..78c1689a 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -127,9 +127,9 @@ -- :} -- -- >>> renderManipulation insertUser --- "INSERT INTO \"users\" (\"id\", \"name\") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING \"id\" AS \"fromOnly\";" +-- "INSERT INTO \"users\" (\"id\", \"name\") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING \"id\" AS \"fromOnly\"" -- >>> renderManipulation insertEmail --- "INSERT INTO \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING;" +-- "INSERT INTO \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING" -- -- Next we write a `Query` to retrieve users from the database. We're not -- interested in the ids here, just the usernames and email addresses. We diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index a052d643..ecef00e4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -50,7 +50,6 @@ import Control.DeepSeq import Data.ByteString hiding (foldr) import Data.Monoid -import qualified Data.ByteString as ByteString import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC @@ -76,7 +75,7 @@ let insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) in renderManipulation manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT);" +"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT)" parameterized insert: @@ -92,7 +91,7 @@ let (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil) in renderManipulation manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4));" +"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4))" returning insert: @@ -108,7 +107,7 @@ let OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil)) in renderManipulation manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\";" +"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\"" upsert: @@ -129,7 +128,7 @@ let (Returning $ (#col1 + #col2) `As` #sum :* Nil) in renderManipulation manipulation :} -"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\";" +"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\"" query insert: @@ -150,7 +149,7 @@ let (selectStar (from (table (#other_tab `As` #t)))) in renderManipulation manipulation :} -"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\";" +"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\"" update: @@ -165,7 +164,7 @@ let (#col1 ./= #col2) in renderManipulation manipulation :} -"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\");" +"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\")" delete: @@ -180,7 +179,7 @@ let manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar in renderManipulation manipulation :} -"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;" +"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *" -} newtype Manipulation (schema :: SchemaType) @@ -193,7 +192,7 @@ newtype Manipulation queryStatement :: Query schema params columns -> Manipulation schema params columns -queryStatement q = UnsafeManipulation $ renderQuery q <> ";" +queryStatement q = UnsafeManipulation $ renderQuery q {----------------------------------------- INSERT statements @@ -345,10 +344,10 @@ renderReturningClause => ReturningClause params columns results -> ByteString renderReturningClause = \case - ReturningStar -> " RETURNING *;" - Returning Nil -> ";" + ReturningStar -> " RETURNING *" + Returning Nil -> "" Returning results -> " RETURNING" - <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";" + <+> renderCommaSeparated (renderAliasedAs renderExpression) results -- | A `ConflictClause` specifies an action to perform upon a constraint -- violation. `OnConflictDoRaise` will raise an error. @@ -484,7 +483,7 @@ WITH statements -- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t))))) -- in renderManipulation manipulation -- :} --- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\";" +-- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\"" with :: SOP.SListI commons => NP (Aliased (Manipulation schema params)) commons @@ -500,9 +499,4 @@ with commons manipulation = UnsafeManipulation $ -> ByteString renderCommon (common `As` alias) = renderAlias alias <+> "AS" <+> - let - str = renderManipulation common - len = ByteString.length str - str' = ByteString.take (len - 1) str -- remove ';' - in - parenthesized str' + parenthesized (renderManipulation common) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs index 6f0ab0e5..25b10834 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs @@ -395,7 +395,8 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema) let toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary) params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params)) - resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary + q' = q <> ";" + resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary case resultMaybe of Nothing -> error "manipulateParams: LibPQ.execParams returned no results" From 75555381d892489d86f477f15856e57d4f080b13 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 1 Jun 2018 14:10:34 -0700 Subject: [PATCH 35/92] embed Haskell types in PGType --- .../src/Squeal/PostgreSQL/Definition.hs | 42 +++++--- .../src/Squeal/PostgreSQL/Schema.hs | 99 ++++++++++++++++++- 2 files changed, 128 insertions(+), 13 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index ff78b133..cb85862b 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -23,6 +23,7 @@ Squeal data definition language. , TypeApplications , TypeInType , TypeOperators + , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Definition @@ -66,7 +67,7 @@ module Squeal.PostgreSQL.Definition -- * Types , createType , createTypeEnum - , createTypeEnumFromHaskell + , createTypeEnumWith , dropType , ColumnTypeExpression (..) , hasNull @@ -790,17 +791,27 @@ createTypeEnum enum labels = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> parenthesized (commaSeparated (renderLabels labels)) <> ";" -createTypeEnumFromHaskell - :: forall enum labels hask proxy schema - . ( KnownSymbol enum - , SOP.All KnownSymbol labels - , SOP.IsEnumType hask - , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) ) - => Alias enum - -> proxy hask - -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) -createTypeEnumFromHaskell enum _ = createTypeEnum enum - (SOP.hpure label :: NP PGlabel labels) +class + ( SOP.IsEnumType hask + , PGenumWith hask ~ 'PGenum labels + ) => HasPGenum hask where + createTypeEnumWith + :: KnownSymbol enum + => Alias enum + -> Definition schema (Create enum ('Typedef (PGenumWith hask)) schema) + createTypeEnumWith enum = createTypeEnum enum + (SOP.hpure label :: NP PGlabel labels) +-- createTypeEnumWith +-- :: forall enum labels hask proxy schema +-- . ( KnownSymbol enum +-- , SOP.All KnownSymbol labels +-- , SOP.IsEnumType hask +-- , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) ) +-- => Alias enum +-- -> proxy hask +-- -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) +-- createTypeEnumWith enum _ = createTypeEnum enum +-- (SOP.hpure label :: NP PGlabel labels) createType :: (KnownSymbol comp, SOP.SListI fields) @@ -811,6 +822,13 @@ createType comp fields = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";" +-- class HasPGcomposite hask where +-- createTypeCompositeWith +-- :: Alias composite +-- -> Definition schema +-- (Create composite ('Typedef ('PGcompositeWith hask)) schema) +-- createTypeCompositeWith + dropType :: Has tydef schema ('Typedef ty) => Alias tydef diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 580d5ac0..67ba7c99 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -105,17 +105,38 @@ module Squeal.PostgreSQL.Schema , SchemumType (..) , SchemaType , With + -- * STUFF + , PG + , PGenumWith + , PGcompositeWith + , ConstructorsOf + , ConstructorNameOf + , ConstructorNamesOf + , FieldsOf + , FieldNameOf + , FieldNamesOf + , FieldTypeOf + , FieldTypesOf + , RecordFieldTypesOf + , Zip ) where import Control.DeepSeq -import Data.ByteString +import Data.Aeson (Value) +import Data.ByteString (ByteString) +import Data.Int import Data.Kind import Data.Monoid hiding (All) +import Data.Scientific import Data.String +import Data.Text (Text) +import Data.Time import Data.Word import Data.Type.Bool +import Data.UUID.Types (UUID) import GHC.OverloadedLabels import GHC.TypeLits +import Network.IP.Addr import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP @@ -653,3 +674,79 @@ type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where DatatypeLabels ('Type.ADT _module _datatype constructors) = LabelsOf constructors + +type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where + PG Bool = 'PGbool + PG Int16 = 'PGint2 + PG Int32 = 'PGint4 + PG Int64 = 'PGint8 + PG Scientific = 'PGnumeric + PG Float = 'PGfloat4 + PG Double = 'PGfloat8 + PG Text = 'PGtext + PG ByteString = 'PGbytea + PG LocalTime = 'PGtimestamp + PG UTCTime = 'PGtimestamptz + PG Day = 'PGdate + PG TimeOfDay = 'PGtime + PG (TimeOfDay, TimeZone) = 'PGtimetz + PG DiffTime = 'PGinterval + PG UUID = 'PGuuid + PG (NetAddr IP) = 'PGinet + PG Value = 'PGjson + +type family PGenumWith (hask :: Type) :: PGType where + PGenumWith hask = + 'PGenum (ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))) + +type family PGcompositeWith (hask :: Type) :: PGType where + PGcompositeWith hask = + 'PGcomposite (Zip + (FieldNamesOf (FieldsOf (SOP.DatatypeInfoOf hask))) + (RecordFieldTypesOf (SOP.Code hask))) + +type family ConstructorsOf (datatype :: Type.DatatypeInfo) + :: [Type.ConstructorInfo] where + ConstructorsOf ('Type.ADT _module _datatype constructors) = + constructors + ConstructorsOf ('Type.Newtype _module _datatype constructor) = + '[constructor] + +type family ConstructorNameOf (constructors :: Type.ConstructorInfo) + :: Type.ConstructorName where + ConstructorNameOf ('Type.Constructor name) = name + ConstructorNameOf ('Type.Infix name _assoc _fix) = name + ConstructorNameOf ('Type.Record name _fields) = name + +type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo]) + :: [Type.ConstructorName] where + ConstructorNamesOf '[] = '[] + ConstructorNamesOf (constructor ': constructors) = + ConstructorNameOf constructor ': ConstructorNamesOf constructors + +type family FieldsOf (constructor :: Type.DatatypeInfo) + :: [Type.FieldInfo] where + FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) = + fields + +type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where + FieldNameOf ('Type.FieldInfo name) = name + +type family FieldNamesOf (fields :: [Type.FieldInfo]) + :: [Type.FieldName] where + FieldNamesOf '[] = '[] + FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields + +type family FieldTypeOf (maybe :: Type) where + FieldTypeOf (Maybe hask) = PG hask + +type family FieldTypesOf (fields :: [Type]) where + FieldTypesOf '[] = '[] + FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields + +type family RecordFieldTypesOf (code :: [[Type]]) where + RecordFieldTypesOf '[fields] = FieldTypesOf fields + +type family Zip xs ys where + Zip '[] '[] = '[] + Zip (x ': xs) (y ': ys) = '(x,y) ': Zip xs ys From e027edec0fa22ebffedbbcafe973339a843d4c2e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 1 Jun 2018 14:18:46 -0700 Subject: [PATCH 36/92] createTypeEnumWith --- .../src/Squeal/PostgreSQL/Definition.hs | 20 +++++-------------- .../src/Squeal/PostgreSQL/Schema.hs | 4 ++-- 2 files changed, 7 insertions(+), 17 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index cb85862b..493bb024 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -9,7 +9,8 @@ Squeal data definition language. -} {-# LANGUAGE - ConstraintKinds + AllowAmbiguousTypes + , ConstraintKinds , DeriveGeneric , FlexibleContexts , FlexibleInstances @@ -793,25 +794,14 @@ createTypeEnum enum labels = UnsafeDefinition $ class ( SOP.IsEnumType hask - , PGenumWith hask ~ 'PGenum labels + , SOP.All KnownSymbol (PGenumWith hask) ) => HasPGenum hask where createTypeEnumWith :: KnownSymbol enum => Alias enum - -> Definition schema (Create enum ('Typedef (PGenumWith hask)) schema) + -> Definition schema (Create enum ('Typedef ('PGenum (PGenumWith hask))) schema) createTypeEnumWith enum = createTypeEnum enum - (SOP.hpure label :: NP PGlabel labels) --- createTypeEnumWith --- :: forall enum labels hask proxy schema --- . ( KnownSymbol enum --- , SOP.All KnownSymbol labels --- , SOP.IsEnumType hask --- , labels ~ DatatypeLabels (SOP.DatatypeInfoOf hask) ) --- => Alias enum --- -> proxy hask --- -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) --- createTypeEnumWith enum _ = createTypeEnum enum --- (SOP.hpure label :: NP PGlabel labels) + (SOP.hpure label :: NP PGlabel (PGenumWith hask)) createType :: (KnownSymbol comp, SOP.SListI fields) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 67ba7c99..e8f38f1c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -695,9 +695,9 @@ type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where PG (NetAddr IP) = 'PGinet PG Value = 'PGjson -type family PGenumWith (hask :: Type) :: PGType where +type family PGenumWith (hask :: Type) :: [Type.ConstructorName] where PGenumWith hask = - 'PGenum (ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))) + ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask)) type family PGcompositeWith (hask :: Type) :: PGType where PGcompositeWith hask = From 8f2ed09f6418bd49276844f4692a3f4d26303959 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 1 Jun 2018 15:04:51 -0700 Subject: [PATCH 37/92] ZipAliased --- .../src/Squeal/PostgreSQL/Schema.hs | 29 +++++++++++++++---- 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index e8f38f1c..6ae054d2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -58,6 +58,7 @@ module Squeal.PostgreSQL.Schema , Aliased (As) , renderAliasedAs , AliasesOf + , ZipAliased (..) , Has , HasUnique , HasAll @@ -118,7 +119,6 @@ module Squeal.PostgreSQL.Schema , FieldTypeOf , FieldTypesOf , RecordFieldTypesOf - , Zip ) where import Control.DeepSeq @@ -413,6 +413,27 @@ type family AliasesOf aliaseds where AliasesOf '[] = '[] AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys +class SOP.All KnownSymbol ns => ZipAliased ns xs where + + type family ZipAs + (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs + + zipAliases + :: SOP.NP Alias ns + -> SOP.NP expr xs + -> SOP.NP (Aliased expr) (ZipAs ns xs) + +instance ZipAliased '[] '[] where + type ZipAs '[] '[] = '[] + zipAliases SOP.Nil SOP.Nil = SOP.Nil + +instance + ( KnownSymbol n + , ZipAliased ns xs + ) => ZipAliased (n ': ns) (x ': xs) where + type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs + zipAliases (n SOP.:* ns) (x SOP.:* xs) = x `As` n SOP.:* zipAliases ns xs + -- | @HasUnique alias fields field@ is a constraint that proves that -- @fields@ is a singleton of @alias ::: field@. type HasUnique alias fields field = fields ~ '[alias ::: field] @@ -701,7 +722,7 @@ type family PGenumWith (hask :: Type) :: [Type.ConstructorName] where type family PGcompositeWith (hask :: Type) :: PGType where PGcompositeWith hask = - 'PGcomposite (Zip + 'PGcomposite (ZipAs (FieldNamesOf (FieldsOf (SOP.DatatypeInfoOf hask))) (RecordFieldTypesOf (SOP.Code hask))) @@ -746,7 +767,3 @@ type family FieldTypesOf (fields :: [Type]) where type family RecordFieldTypesOf (code :: [[Type]]) where RecordFieldTypesOf '[fields] = FieldTypesOf fields - -type family Zip xs ys where - Zip '[] '[] = '[] - Zip (x ': xs) (y ': ys) = '(x,y) ': Zip xs ys From 6fa1d5f13ac86c07adf819a8b887e61747408e56 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 1 Jun 2018 16:38:51 -0700 Subject: [PATCH 38/92] get embedding and some cleanup --- .../src/Squeal/PostgreSQL/Binary.hs | 10 +- .../src/Squeal/PostgreSQL/Definition.hs | 47 +++-- .../src/Squeal/PostgreSQL/Expression.hs | 2 +- .../src/Squeal/PostgreSQL/Schema.hs | 181 +++++++++--------- 4 files changed, 119 insertions(+), 121 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 0190249e..46d459db 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -121,7 +121,7 @@ instance (HasOid pg, ToParam x pg) instance ( IsEnumType x , HasDatatypeInfo x - , SameLabels (DatatypeInfoOf x) labels + , LabelsWith x ~ labels ) => ToParam x ('PGenum labels) where toParam = let @@ -141,7 +141,7 @@ instance , MapMaybes xs , IsProductType x (Maybes xs) , AllZip ToAliasedParam xs fields - , SameFields (DatatypeInfoOf x) fields + , FieldNamesWith x ~ AliasesOf fields , All HasAliasedOid fields ) => ToParam x ('PGcomposite fields) where toParam = @@ -277,7 +277,7 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where instance ( IsEnumType y , HasDatatypeInfo y - , SameLabels (DatatypeInfoOf y) labels + , LabelsWith y ~ labels ) => FromValue ('PGenum labels) y where fromValue _ = let @@ -302,7 +302,7 @@ instance , MapMaybes ys , IsProductType y (Maybes ys) , AllZip FromAliasedValue fields ys - , SameFields (DatatypeInfoOf y) fields + , FieldNamesWith y ~ AliasesOf fields ) => FromValue ('PGcomposite fields) y where fromValue = let @@ -395,7 +395,7 @@ instance ( SListI results , IsProductType y ys , AllZip FromColumnValue results ys - , SameFields (DatatypeInfoOf y) results + , FieldNamesWith y ~ AliasesOf results ) => FromRow results y where fromRow = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 493bb024..2d2bd0d5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -66,9 +66,10 @@ module Squeal.PostgreSQL.Definition , createView , dropView -- * Types - , createType + , createTypeComposite , createTypeEnum - , createTypeEnumWith + , HasPGcomposite (..) + , HasPGenum (..) , dropType , ColumnTypeExpression (..) , hasNull @@ -242,9 +243,9 @@ newtype TableConstraintExpression -- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));" check :: ( Has alias schema ('Table table) - , HasAll aliases (TableToColumns table) subcolumns ) + , HasAll aliases (TableToRelation table) subcolumns ) => NP Alias aliases - -> (forall tab. Condition '[tab ::: ColumnsToRelation subcolumns] 'Ungrouped '[]) + -> (forall tab. Condition '[tab ::: subcolumns] 'Ungrouped '[]) -> TableConstraintExpression schema alias ('Check aliases) check _cols condition = UnsafeTableConstraintExpression $ "CHECK" <+> parenthesized (renderExpression condition) @@ -273,7 +274,7 @@ check _cols condition = UnsafeTableConstraintExpression $ -- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" int NULL, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" unique :: ( Has alias schema ('Table table) - , HasAll aliases (TableToColumns table) subcolumns ) + , HasAll aliases (TableToRelation table) subcolumns ) => NP Alias aliases -> TableConstraintExpression schema alias ('Unique aliases) unique columns = UnsafeTableConstraintExpression $ @@ -794,30 +795,36 @@ createTypeEnum enum labels = UnsafeDefinition $ class ( SOP.IsEnumType hask - , SOP.All KnownSymbol (PGenumWith hask) + , SOP.All KnownSymbol (LabelsWith hask) ) => HasPGenum hask where createTypeEnumWith :: KnownSymbol enum => Alias enum - -> Definition schema (Create enum ('Typedef ('PGenum (PGenumWith hask))) schema) + -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema) createTypeEnumWith enum = createTypeEnum enum - (SOP.hpure label :: NP PGlabel (PGenumWith hask)) + (SOP.hpure label :: NP PGlabel (LabelsWith hask)) -createType - :: (KnownSymbol comp, SOP.SListI fields) - => Alias comp +createTypeComposite + :: (KnownSymbol ty, SOP.SListI fields) + => Alias ty -> NP (Aliased TypeExpression) fields - -> Definition schema (Create comp ('Typedef ('PGcomposite fields)) schema) -createType comp fields = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized + -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema) +createTypeComposite ty fields = UnsafeDefinition $ + "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";" --- class HasPGcomposite hask where --- createTypeCompositeWith --- :: Alias composite --- -> Definition schema --- (Create composite ('Typedef ('PGcompositeWith hask)) schema) --- createTypeCompositeWith +class + ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask) + , SOP.All PGTyped (FieldTypesWith hask) + ) => HasPGcomposite hask where + createTypeCompositeWith + :: KnownSymbol ty + => Alias ty + -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema) + createTypeCompositeWith ty = createTypeComposite ty $ zipAs + (SOP.hpure Alias :: NP Alias (FieldNamesWith hask)) + (SOP.hcpure (SOP.Proxy :: SOP.Proxy PGTyped) pgtype + :: NP TypeExpression (FieldTypesWith hask)) dropType :: Has tydef schema ('Typedef ty) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 0bf18436..374f0ae9 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -1045,7 +1045,7 @@ newtype Table deriving (GHC.Generic,Show,Eq,Ord,NFData) instance ( Has alias schema ('Table table) - , relation ~ ColumnsToRelation (TableToColumns table) + , relation ~ TableToRelation table ) => IsLabel alias (Table schema relation) where fromLabel = UnsafeTable $ renderAlias (Alias @alias) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 6ae054d2..7425e56a 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -40,6 +40,9 @@ module Squeal.PostgreSQL.Schema , NilRelation , RelationsType , TableType + -- * Schema + , SchemumType (..) + , SchemaType -- * Grouping , Grouping (..) , GroupedBy @@ -66,6 +69,7 @@ module Squeal.PostgreSQL.Schema , IsQualified (..) -- * Type Families , Join + , With , Create , Drop , Alter @@ -84,32 +88,27 @@ module Squeal.PostgreSQL.Schema , NullifyRelation , NullifyRelations , ColumnsToRelation - , RelationToColumns , TableToColumns + , TableToRelation , ConstraintInvolves , DropIfConstraintsInvolve -- * Generics - , SameField - , SameFields - , SameLabel - , SameLabels , MapMaybes (..) , Nulls + -- * Enum Labels , IsPGlabel (..) , PGlabel (..) , renderLabel , renderLabels , LabelOf , LabelsOf - , DatatypeLabels - -- * Schema - , SchemumType (..) - , SchemaType - , With - -- * STUFF + -- * Embedding , PG - , PGenumWith - , PGcompositeWith + , EnumWith + , LabelsWith + , CompositeWith + , FieldNamesWith + , FieldTypesWith , ConstructorsOf , ConstructorNameOf , ConstructorNamesOf @@ -118,28 +117,30 @@ module Squeal.PostgreSQL.Schema , FieldNamesOf , FieldTypeOf , FieldTypesOf - , RecordFieldTypesOf + , RecordCodeOf ) where import Control.DeepSeq import Data.Aeson (Value) import Data.ByteString (ByteString) -import Data.Int +import Data.Int (Int16, Int32, Int64) import Data.Kind import Data.Monoid hiding (All) -import Data.Scientific +import Data.Scientific (Scientific) import Data.String import Data.Text (Text) import Data.Time -import Data.Word +import Data.Word (Word16, Word32, Word64) import Data.Type.Bool import Data.UUID.Types (UUID) +import Generics.SOP import GHC.OverloadedLabels import GHC.TypeLits import Network.IP.Addr +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Text.Lazy as Lazy import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP import qualified Generics.SOP.Type.Metadata as Type import Squeal.PostgreSQL.Render @@ -323,16 +324,13 @@ type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where ColumnsToRelation (column ::: constraint :=> ty ': columns) = column ::: ty ': ColumnsToRelation columns --- | `RelationToColumns` adds `'NoDef` column constraints. -type family RelationToColumns (relation :: RelationType) :: ColumnsType where - RelationToColumns '[] = '[] - RelationToColumns (column ::: ty ': columns) = - column ::: 'NoDef :=> ty ': RelationToColumns columns - -- | `TableToColumns` removes table constraints. type family TableToColumns (table :: TableType) :: ColumnsType where TableToColumns (constraints :=> columns) = columns +type family TableToRelation (table :: TableType) :: RelationType where + TableToRelation tab = ColumnsToRelation (TableToColumns tab) + -- | `Grouping` is an auxiliary namespace, created by -- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used -- for typesafe aggregation @@ -364,8 +362,8 @@ data Alias (alias :: Symbol) = Alias deriving (Eq,GHC.Generic,Ord,Show,NFData) instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where fromLabel = Alias -instance aliases ~ '[alias] => IsLabel alias (SOP.NP Alias aliases) where - fromLabel = fromLabel SOP.:* SOP.Nil +instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where + fromLabel = fromLabel :* Nil -- | >>> renderAlias #jimbob -- "\"jimbob\"" @@ -376,9 +374,9 @@ renderAlias = doubleQuoted . fromString . symbolVal -- >>> renderAliases (#jimbob :* #kandi :* Nil) -- ["\"jimbob\"","\"kandi\""] renderAliases - :: SOP.All KnownSymbol aliases => SOP.NP Alias aliases -> [ByteString] -renderAliases = SOP.hcollapse - . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderAlias) + :: All KnownSymbol aliases => NP Alias aliases -> [ByteString] +renderAliases = hcollapse + . hcmap (Proxy @KnownSymbol) (K . renderAlias) -- | The `As` operator is used to name an expression. `As` is like a demoted -- version of `:::`. @@ -413,26 +411,29 @@ type family AliasesOf aliaseds where AliasesOf '[] = '[] AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys -class SOP.All KnownSymbol ns => ZipAliased ns xs where +class + ( SListI (ZipAs ns xs) + , All KnownSymbol ns + ) => ZipAliased ns xs where type family ZipAs (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs - zipAliases - :: SOP.NP Alias ns - -> SOP.NP expr xs - -> SOP.NP (Aliased expr) (ZipAs ns xs) + zipAs + :: NP Alias ns + -> NP expr xs + -> NP (Aliased expr) (ZipAs ns xs) instance ZipAliased '[] '[] where type ZipAs '[] '[] = '[] - zipAliases SOP.Nil SOP.Nil = SOP.Nil + zipAs Nil Nil = Nil instance ( KnownSymbol n , ZipAliased ns xs ) => ZipAliased (n ': ns) (x ': xs) where type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs - zipAliases (n SOP.:* ns) (x SOP.:* xs) = x `As` n SOP.:* zipAliases ns xs + zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs -- | @HasUnique alias fields field@ is a constraint that proves that -- @fields@ is a singleton of @alias ::: field@. @@ -449,7 +450,7 @@ instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field) => Has alias (field' ': fields) field class - ( SOP.All KnownSymbol aliases + ( All KnownSymbol aliases ) => HasAll (aliases :: [Symbol]) (fields :: [(Symbol,kind)]) @@ -592,50 +593,18 @@ type family Rename alias0 alias1 xs where Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs --- | A `SameField` constraint is an equality constraint on a --- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair. -class SameField - (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where -instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty) - --- | A `SameFields` constraint proves that a --- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same --- field names as the column AliasesOf of a `ColumnsType`. -type family SameFields - (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ty)]) - :: Constraint where - SameFields - ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields]) - columns - = SOP.AllZip SameField fields columns - SameFields - ('Type.Newtype _module _datatype ('Type.Record _constructor fields)) - columns - = SOP.AllZip SameField fields columns - -class SameLabel - (constrInfo :: Type.ConstructorInfo) (label :: Symbol) where -instance name ~ label => SameLabel ('Type.Constructor name) label - -type family SameLabels - (datatypeInfo :: Type.DatatypeInfo) (labels :: [Symbol]) - :: Constraint where - SameLabels - ('Type.ADT _module _datatype constructors) labels - = SOP.AllZip SameLabel constructors labels - class MapMaybes xs where type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs - maybes :: SOP.NP Maybe xs -> SOP.NP SOP.I (Maybes xs) - unMaybes :: SOP.NP SOP.I (Maybes xs) -> SOP.NP Maybe xs + maybes :: NP Maybe xs -> NP I (Maybes xs) + unMaybes :: NP I (Maybes xs) -> NP Maybe xs instance MapMaybes '[] where type Maybes '[] = '[] - maybes SOP.Nil = SOP.Nil - unMaybes SOP.Nil = SOP.Nil + maybes Nil = Nil + unMaybes Nil = Nil instance MapMaybes xs => MapMaybes (x ': xs) where type Maybes (x ': xs) = Maybe x ': Maybes xs - maybes (x SOP.:* xs) = SOP.I x SOP.:* maybes xs - unMaybes (SOP.I mx SOP.:* xs) = mx SOP.:* unMaybes xs + maybes (x :* xs) = I x :* maybes xs + unMaybes (I mx :* xs) = mx :* unMaybes xs type family Nulls tys where Nulls '[] = '[] @@ -679,12 +648,12 @@ data PGlabel (label :: Symbol) = PGlabel renderLabel :: KnownSymbol label => proxy label -> ByteString renderLabel (_ :: proxy label) = - "\'" <> fromString (symbolVal (SOP.Proxy @label)) <> "\'" + "\'" <> fromString (symbolVal (Proxy @label)) <> "\'" renderLabels - :: SOP.All KnownSymbol labels => SOP.NP PGlabel labels -> [ByteString] -renderLabels = SOP.hcollapse - . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderLabel) + :: All KnownSymbol labels => NP PGlabel labels -> [ByteString] +renderLabels = hcollapse + . hcmap (Proxy @KnownSymbol) (K . renderLabel) type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where LabelOf ('Type.Constructor name) = name @@ -693,19 +662,22 @@ type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where LabelsOf '[] = '[] LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss -type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where - DatatypeLabels ('Type.ADT _module _datatype constructors) = LabelsOf constructors - -type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where +type family PG (hask :: Type) :: PGType where PG Bool = 'PGbool PG Int16 = 'PGint2 PG Int32 = 'PGint4 PG Int64 = 'PGint8 + PG Word16 = 'PGint2 + PG Word32 = 'PGint4 + PG Word64 = 'PGint8 PG Scientific = 'PGnumeric PG Float = 'PGfloat4 PG Double = 'PGfloat8 + PG Char = 'PGchar 1 PG Text = 'PGtext + PG Lazy.Text = 'PGtext PG ByteString = 'PGbytea + PG Lazy.ByteString = 'PGbytea PG LocalTime = 'PGtimestamp PG UTCTime = 'PGtimestamptz PG Day = 'PGdate @@ -715,16 +687,25 @@ type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where PG UUID = 'PGuuid PG (NetAddr IP) = 'PGinet PG Value = 'PGjson + PG ty = TypeError + ('Text "There is no basic Postgres type for " ':<>: 'ShowType ty) -type family PGenumWith (hask :: Type) :: [Type.ConstructorName] where - PGenumWith hask = - ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask)) +type family EnumWith (hask :: Type) :: PGType where + EnumWith hask = 'PGenum (LabelsWith hask) -type family PGcompositeWith (hask :: Type) :: PGType where - PGcompositeWith hask = - 'PGcomposite (ZipAs - (FieldNamesOf (FieldsOf (SOP.DatatypeInfoOf hask))) - (RecordFieldTypesOf (SOP.Code hask))) +type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where + LabelsWith hask = + ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask)) + +type family CompositeWith (hask :: Type) :: PGType where + CompositeWith hask = + 'PGcomposite (ZipAs (FieldNamesWith hask) (FieldTypesWith hask)) + +type family FieldNamesWith (hask :: Type) :: [Type.FieldName] where + FieldNamesWith hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask)) + +type family FieldTypesWith (hask :: Type) :: [PGType] where + FieldTypesWith hask = FieldTypesOf (RecordCodeOf hask (Code hask)) type family ConstructorsOf (datatype :: Type.DatatypeInfo) :: [Type.ConstructorInfo] where @@ -736,8 +717,12 @@ type family ConstructorsOf (datatype :: Type.DatatypeInfo) type family ConstructorNameOf (constructors :: Type.ConstructorInfo) :: Type.ConstructorName where ConstructorNameOf ('Type.Constructor name) = name - ConstructorNameOf ('Type.Infix name _assoc _fix) = name - ConstructorNameOf ('Type.Record name _fields) = name + ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError + ('Text "ConstructorNameOf error: non-nullary constructor " + ':<>: 'Text name) + ConstructorNameOf ('Type.Record name _fields) = TypeError + ('Text "ConstructorNameOf error: non-nullary constructor " + ':<>: 'Text name) type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo]) :: [Type.ConstructorName] where @@ -749,6 +734,8 @@ type family FieldsOf (constructor :: Type.DatatypeInfo) :: [Type.FieldInfo] where FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) = fields + FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) = + fields type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where FieldNameOf ('Type.FieldInfo name) = name @@ -760,10 +747,14 @@ type family FieldNamesOf (fields :: [Type.FieldInfo]) type family FieldTypeOf (maybe :: Type) where FieldTypeOf (Maybe hask) = PG hask + FieldTypeOf ty = TypeError + ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty) type family FieldTypesOf (fields :: [Type]) where FieldTypesOf '[] = '[] FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields -type family RecordFieldTypesOf (code :: [[Type]]) where - RecordFieldTypesOf '[fields] = FieldTypesOf fields +type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where + RecordCodeOf _hask '[tys] = tys + RecordCodeOf hask _tys = TypeError + ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask) From d531baa746ebe90a0352d066e7c8898223c359e8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 2 Jun 2018 12:42:16 -0700 Subject: [PATCH 39/92] More sugary instances --- .../src/Squeal/PostgreSQL/Expression.hs | 40 ++++++++++++++++++- .../src/Squeal/PostgreSQL/Query.hs | 2 +- 2 files changed, 40 insertions(+), 2 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 374f0ae9..bf87cbec 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -199,10 +199,30 @@ instance (HasUnique relation relations columns, Has column columns ty) => IsLabel column (Expression relations 'Ungrouped params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) +instance (HasUnique relation relations columns, Has column columns ty) + => IsLabel column + (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where + fromLabel = fromLabel @column `As` Alias @column + +instance (HasUnique relation relations columns, Has column columns ty) + => IsLabel column + (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where + fromLabel = fromLabel @column :* Nil + instance (Has relation relations columns, Has column columns ty) => IsQualified relation column (Expression relations 'Ungrouped params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column + +instance (Has relation relations columns, Has column columns ty) + => IsQualified relation column + (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where + relation ! column = relation ! column `As` column + +instance (Has relation relations columns, Has column columns ty) + => IsQualified relation column + (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where + relation ! column = relation ! column :* Nil instance ( HasUnique relation relations columns @@ -211,7 +231,7 @@ instance ) => IsLabel column (Expression relations ('Grouped bys) params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) - + instance ( Has relation relations columns , Has column columns ty @@ -221,6 +241,24 @@ instance relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column +instance + ( Has relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsQualified relation column + (Aliased (Expression relations ('Grouped bys) params) + (column ::: ty)) where + relation ! column = relation ! column `As` column + +instance + ( Has relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsQualified relation column + ( NP (Aliased (Expression relations ('Grouped bys) params)) + '[column ::: ty]) where + relation ! column = relation ! column :* Nil + -- | analagous to `Nothing` -- -- >>> renderExpression $ null_ diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index a76bbf3c..57aae466 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -114,7 +114,7 @@ let , "col1" ::: 'NotNull 'PGint4 ] query = select - ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil) + ((#col1 + #col2) `As` #sum :* #col1 :* Nil) ( from (table (#tab `As` #t)) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) ) From 06a7c053e3c43285078859886eb1042f815bf4f7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 2 Jun 2018 12:44:19 -0700 Subject: [PATCH 40/92] trim trailing whitespaces --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 4 ++-- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 4 ++-- squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs | 4 ++-- .../src/Squeal/PostgreSQL/Manipulation.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs | 4 ++-- squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL/Query.hs | 10 +++++----- squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs | 8 ++++---- 8 files changed, 19 insertions(+), 19 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 46d459db..95a05af9 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -193,7 +193,7 @@ instance ToParam x ty => ToAliasedParam x (alias ::: ty) where Nothing -> K Nothing Just x -> K . Just . unK $ toParam @x @ty x --- | A `ToColumnParam` constraint lifts the `ToParam` encoding +-- | A `ToColumnParam` constraint lifts the `ToParam` encoding -- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should -- not define instances of `ToColumnParam`, just use the provided instances. class ToColumnParam (x :: Type) (ty :: NullityType) where @@ -279,7 +279,7 @@ instance , HasDatatypeInfo y , LabelsWith y ~ labels ) => FromValue ('PGenum labels) y where - fromValue _ = + fromValue _ = let greadConstructor :: All ((~) '[]) xss diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 2d2bd0d5..6efc21db 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -338,7 +338,7 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- >>> :{ -- let -- setup :: Definition '[] Schema --- setup = +-- setup = -- createTable #users -- ( serial `As` #id :* -- (text & hasNotNull) `As` #name :* Nil ) @@ -372,7 +372,7 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- >>> :{ -- let -- setup :: Definition '[] Schema --- setup = +-- setup = -- createTable #employees -- ( serial `As` #id :* -- (text & hasNotNull) `As` #name :* diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index bf87cbec..13ac910c 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -27,7 +27,7 @@ Squeal expressions are the atoms used to build statements. , UndecidableInstances #-} -module Squeal.PostgreSQL.Expression +module Squeal.PostgreSQL.Expression ( -- * Expression Expression (UnsafeExpression, renderExpression) , HasParameter (param) @@ -223,7 +223,7 @@ instance (Has relation relations columns, Has column columns ty) => IsQualified relation column (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where relation ! column = relation ! column :* Nil - + instance ( HasUnique relation relations columns , Has column columns ty diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index ecef00e4..1d165f7f 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -144,7 +144,7 @@ let , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]) ] '[] '[] - manipulation = + manipulation = insertQuery_ #tab (selectStar (from (table (#other_tab `As` #t)))) in renderManipulation manipulation diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs index 25b10834..258b5f86 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs @@ -166,7 +166,7 @@ instance Monad m => Functor (PQ schema0 schema1 m) where K x <- pq conn return $ K (f x) --- | Run a `PQ` and keep the result and the `Connection`. +-- | Run a `PQ` and keep the result and the `Connection`. runPQ :: Functor m => PQ schema0 schema1 m x @@ -176,7 +176,7 @@ runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn -- K x <- pq conn -- return (x, K (unK conn)) --- | Execute a `PQ` and discard the result but keep the `Connection`. +-- | Execute a `PQ` and discard the result but keep the `Connection`. execPQ :: Functor m => PQ schema0 schema1 m x diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs index f19bbad1..42584aca 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs @@ -109,7 +109,7 @@ instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where (_ :: K () schema) <- flip unPQ conn $ traversePrepared_ manipulation params return () - liftPQ m = PoolPQ $ \ pool -> + liftPQ m = PoolPQ $ \ pool -> withResource pool $ \ conn -> do (K result :: K result schema) <- flip unPQ conn $ liftPQ m diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 57aae466..55445a1d 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -112,7 +112,7 @@ let '[] '[ "sum" ::: 'NotNull 'PGint4 , "col1" ::: 'NotNull 'PGint4 ] - query = + query = select ((#col1 + #col2) `As` #sum :* #col1 :* Nil) ( from (table (#tab `As` #t)) @@ -179,7 +179,7 @@ let query = select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil) ( from (table (#tab `As` #table1)) - & group (By #col1 :* Nil) + & group (By #col1 :* Nil) & having (#col1 + sum_ #col2 .> 1) ) in renderQuery query :} @@ -281,7 +281,7 @@ newtype Query deriving (GHC.Generic,Show,Eq,Ord,NFData) -- | The results of two queries can be combined using the set operation --- `union`. Duplicate rows are eliminated. +-- `union`. Duplicate rows are eliminated. union :: Query schema params columns -> Query schema params columns @@ -412,7 +412,7 @@ selectDotStar selectDotStar rel relations = UnsafeQuery $ "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations --- | A `selectDistinctDotStar` asks for all the columns of a particular table, +-- | A `selectDistinctDotStar` asks for all the columns of a particular table, -- and eliminates duplicate rows. selectDistinctDotStar :: Has relation relations columns @@ -555,7 +555,7 @@ where_ wh rels = rels {whereClause = wh : whereClause rels} group :: SListI bys => NP (By relations) bys -- ^ grouped columns - -> TableExpression schema params relations 'Ungrouped + -> TableExpression schema params relations 'Ungrouped -> TableExpression schema params relations ('Grouped bys) group bys rels = TableExpression { fromClause = fromClause rels diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs index 4516c51c..bc689bcb 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs @@ -158,22 +158,22 @@ data IsolationLevel = Serializable -- ^ Dirty read is not possible. -- Nonrepeatable read is not possible. - -- Phantom read is not possible. + -- Phantom read is not possible. -- Serialization anomaly is not possible. | RepeatableRead -- ^ Dirty read is not possible. -- Nonrepeatable read is not possible. - -- Phantom read is not possible. + -- Phantom read is not possible. -- Serialization anomaly is possible. | ReadCommitted -- ^ Dirty read is not possible. -- Nonrepeatable read is possible. - -- Phantom read is possible. + -- Phantom read is possible. -- Serialization anomaly is possible. | ReadUncommitted -- ^ Dirty read is not possible. -- Nonrepeatable read is possible. - -- Phantom read is possible. + -- Phantom read is possible. -- Serialization anomaly is possible. deriving (Show, Eq) From f0e564464fc09b546899fe1e87b5e0a803d0173d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 2 Jun 2018 15:17:26 -0700 Subject: [PATCH 41/92] IsLabel instances for grouped columns --- .../src/Squeal/PostgreSQL/Expression.hs | 22 ++++++++++++++----- .../src/Squeal/PostgreSQL/Query.hs | 2 +- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 13ac910c..ab919bd5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -198,12 +198,10 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty) instance (HasUnique relation relations columns, Has column columns ty) => IsLabel column (Expression relations 'Ungrouped params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) - instance (HasUnique relation relations columns, Has column columns ty) => IsLabel column (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where fromLabel = fromLabel @column `As` Alias @column - instance (HasUnique relation relations columns, Has column columns ty) => IsLabel column (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where @@ -213,12 +211,10 @@ instance (Has relation relations columns, Has column columns ty) => IsQualified relation column (Expression relations 'Ungrouped params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column - instance (Has relation relations columns, Has column columns ty) => IsQualified relation column (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where relation ! column = relation ! column `As` column - instance (Has relation relations columns, Has column columns ty) => IsQualified relation column (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where @@ -231,6 +227,22 @@ instance ) => IsLabel column (Expression relations ('Grouped bys) params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) +instance + ( HasUnique relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsLabel column + ( Aliased (Expression relations ('Grouped bys) params) + (column ::: ty) ) where + fromLabel = fromLabel @column `As` Alias @column +instance + ( HasUnique relation relations columns + , Has column columns ty + , GroupedBy relation column bys + ) => IsLabel column + ( NP (Aliased (Expression relations ('Grouped bys) params)) + '[column ::: ty] ) where + fromLabel = fromLabel @column :* Nil instance ( Has relation relations columns @@ -240,7 +252,6 @@ instance (Expression relations ('Grouped bys) params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column - instance ( Has relation relations columns , Has column columns ty @@ -249,7 +260,6 @@ instance (Aliased (Expression relations ('Grouped bys) params) (column ::: ty)) where relation ! column = relation ! column `As` column - instance ( Has relation relations columns , Has column columns ty diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 55445a1d..3e471bce 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -177,7 +177,7 @@ let '[ "sum" ::: 'NotNull 'PGint4 , "col1" ::: 'NotNull 'PGint4 ] query = - select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil) + select (sum_ #col2 `As` #sum :* #col1 :* Nil) ( from (table (#tab `As` #table1)) & group (By #col1 :* Nil) & having (#col1 + sum_ #col2 .> 1) ) From b65851c5b911818fedd9561862e8c2532834b1b9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 2 Jun 2018 15:57:01 -0700 Subject: [PATCH 42/92] aliased aliases --- .../src/Squeal/PostgreSQL/Expression.hs | 32 ------------ .../src/Squeal/PostgreSQL/Query.hs | 51 ++++++++++--------- .../src/Squeal/PostgreSQL/Schema.hs | 3 ++ 3 files changed, 31 insertions(+), 55 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index ab919bd5..cb7a9c9f 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -92,9 +92,6 @@ module Squeal.PostgreSQL.Expression , count, countDistinct , every, everyDistinct , max_, maxDistinct, min_, minDistinct - -- * Tables - , Table (UnsafeTable, renderTable) - , View (UnsafeView, renderView) -- * Types , TypeExpression (UnsafeTypeExpression, renderTypeExpression) , PGTyped (pgtype) @@ -1080,35 +1077,6 @@ min_ = unsafeAggregate "min" maxDistinct = unsafeAggregateDistinct "max" minDistinct = unsafeAggregateDistinct "min" -{----------------------------------------- -tables ------------------------------------------} - --- | A `Table` from a table expression is a way --- to call a table reference by its alias. -newtype Table - (schema :: SchemaType) - (columns :: RelationType) - = UnsafeTable { renderTable :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance - ( Has alias schema ('Table table) - , relation ~ TableToRelation table - ) => IsLabel alias (Table schema relation) where - fromLabel = UnsafeTable $ renderAlias (Alias @alias) - --- | A `View` from a table expression is a way --- to call a table reference by its alias. -newtype View - (schema :: SchemaType) - (columns :: RelationType) - = UnsafeView { renderView :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance - ( Has alias schema ('View columns) - ) => IsLabel alias (View schema columns) where - fromLabel = UnsafeView $ renderAlias (Alias @alias) - {----------------------------------------- type expressions -----------------------------------------} diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 3e471bce..6dcc7630 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -10,6 +10,7 @@ Squeal queries. {-# LANGUAGE DeriveGeneric + , FlexibleContexts , GADTs , GeneralizedNewtypeDeriving , LambdaCase @@ -96,10 +97,10 @@ let '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] '[] '["col" ::: 'Null 'PGint4] - query = selectStar (from (table (#tab `As` #t))) + query = selectStar (from (table #tab)) in renderQuery query :} -"SELECT * FROM \"tab\" AS \"t\"" +"SELECT * FROM \"tab\" AS \"tab\"" restricted query: @@ -115,12 +116,12 @@ let query = select ((#col1 + #col2) `As` #sum :* #col1 :* Nil) - ( from (table (#tab `As` #t)) + ( from (table #tab) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) ) in renderQuery query :} -"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"t\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))" +"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"tab\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))" subquery: @@ -132,10 +133,10 @@ let '["col" ::: 'Null 'PGint4] query = selectStar - (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub))) + (from (subquery (selectStar (from (table #tab)) `As` #sub))) in renderQuery query :} -"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\"" +"SELECT * FROM (SELECT * FROM \"tab\" AS \"tab\") AS \"sub\"" limits and offsets: @@ -146,10 +147,10 @@ let '[] '["col" ::: 'Null 'PGint4] query = selectStar - (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2) + (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2) in renderQuery query :} -"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4" +"SELECT * FROM \"tab\" AS \"tab\" LIMIT 50 OFFSET 4" parameterized query: @@ -160,10 +161,10 @@ let '[ 'NotNull 'PGfloat8] '["col" ::: 'NotNull 'PGfloat8] query = selectStar - (from (table (#tab `As` #t)) & where_ (#col .> param @1)) + (from (table #tab) & where_ (#col .> param @1)) in renderQuery query :} -"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))" +"SELECT * FROM \"tab\" AS \"tab\" WHERE (\"col\" > ($1 :: float8))" aggregation query: @@ -194,10 +195,10 @@ let '[] '["col" ::: 'Null 'PGint4] query = selectStar - (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst]) + (from (table #tab) & orderBy [#col & AscNullsFirst]) in renderQuery query :} -"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST" +"SELECT * FROM \"tab\" AS \"tab\" ORDER BY \"col\" ASC NULLS FIRST" joins: @@ -266,12 +267,12 @@ let '[] '["col" ::: 'Null 'PGint4] query = - selectStar (from (table (#tab `As` #t))) + selectStar (from (table #tab)) `unionAll` - selectStar (from (table (#tab `As` #t))) + selectStar (from (table #tab)) in renderQuery query :} -"(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")" +"(SELECT * FROM \"tab\" AS \"tab\") UNION ALL (SELECT * FROM \"tab\" AS \"tab\")" -} newtype Query (schema :: SchemaType) @@ -614,21 +615,25 @@ newtype FromClause schema params relations -- | A real `table` is a table from the schema. table - :: Aliased (Table schema) table - -> FromClause schema params '[table] -table = UnsafeFromClause . renderAliasedAs renderTable + :: Has tab schema ('Table table) + => Aliased Alias (alias ::: tab) + -> FromClause schema params '[alias ::: TableToRelation table] +table (tab `As` alias) = UnsafeFromClause $ + renderAlias tab <+> "AS" <+> renderAlias alias -- | `subquery` derives a table from a `Query`. subquery - :: Aliased (Query schema params) table - -> FromClause schema params '[table] + :: Aliased (Query schema params) rel + -> FromClause schema params '[rel] subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery) -- | `view` derives a table from a `View`. view - :: Aliased (View schema) table - -> FromClause schema params '[table] -view = UnsafeFromClause . renderAliasedAs renderView + :: Has view schema ('View rel) + => Aliased Alias (alias ::: view) + -> FromClause schema params '[alias ::: rel] +view (vw `As` alias) = UnsafeFromClause $ + renderAlias vw <+> "AS" <+> renderAlias alias {- | @left & crossJoin right@. For every possible combination of rows from @left@ and @right@ (i.e., a Cartesian product), the joined table will contain diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 7425e56a..51c01641 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -395,6 +395,9 @@ deriving instance Eq (expression ty) => Eq (Aliased expression (alias ::: ty)) deriving instance Ord (expression ty) => Ord (Aliased expression (alias ::: ty)) +instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2) + => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where + fromLabel = fromLabel @alias2 `As` fromLabel @alias1 -- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just") -- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int) From d541e42ea4799ffb9b43025d12cbc33e25154337 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 08:34:56 -0700 Subject: [PATCH 43/92] some docs --- .../src/Squeal/PostgreSQL/Schema.hs | 24 +++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 51c01641..74e53a8f 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -629,13 +629,18 @@ type family DropIfConstraintsInvolve column constraints where (DropIfConstraintsInvolve column constraints) (alias ::: constraint ': DropIfConstraintsInvolve column constraints) +-- | A `SchemumType` is a user-defined type, either a `Table`, +-- `View` or `Typedef`. data SchemumType = Table TableType | View RelationType | Typedef PGType +-- | The schema of a database consists of a list of aliased, +-- user-defined `SchemumType`s. type SchemaType = [(Symbol,SchemumType)] +-- | Used in `Squeal.Postgresql.Manipulation.with`. type family With (relations :: RelationsType) (schema :: SchemaType) @@ -644,27 +649,38 @@ type family With With (alias ::: rel ': rels) schema = alias ::: 'View rel ': With rels schema +-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas +-- the overloaded label, `fromLabel` is used for column references, +-- `label`s are used for enum terms. A `label` is called with +-- type application like `label @"beef"`. class IsPGlabel (label :: Symbol) expr where label :: expr instance label ~ label' => IsPGlabel label (PGlabel label') where label = PGlabel +-- | A `PGlabel` unit type with an `IsPGlabel` instance data PGlabel (label :: Symbol) = PGlabel - +-- | Renders a label renderLabel :: KnownSymbol label => proxy label -> ByteString renderLabel (_ :: proxy label) = "\'" <> fromString (symbolVal (Proxy @label)) <> "\'" - +-- | Renders a list of labels renderLabels :: All KnownSymbol labels => NP PGlabel labels -> [ByteString] renderLabels = hcollapse . hcmap (Proxy @KnownSymbol) (K . renderLabel) - +-- | Gets the name of a type constructor type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where LabelOf ('Type.Constructor name) = name - +-- | Gets the names of a list of type constructors type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where LabelsOf '[] = '[] LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss +-- | The `PG` type family embeds a subset of Haskell types +-- as basic Postgres types. +-- +-- >>> :kind! PG LocalTime +-- PG LocalTime :: PGType +-- = 'PGtimestamp type family PG (hask :: Type) :: PGType where PG Bool = 'PGbool PG Int16 = 'PGint2 From 2c7844e185926f080e6000eb48c2b15e4c4d0de8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 11:02:51 -0700 Subject: [PATCH 44/92] documentation and tests --- README.md | 6 +- squeal-postgresql/exe/Example.hs | 8 +- squeal-postgresql/src/Squeal/PostgreSQL.hs | 6 +- .../src/Squeal/PostgreSQL/Definition.hs | 137 ++++++++++++------ .../src/Squeal/PostgreSQL/Expression.hs | 12 +- .../src/Squeal/PostgreSQL/Migration.hs | 10 +- .../src/Squeal/PostgreSQL/Query.hs | 10 ++ .../src/Squeal/PostgreSQL/Schema.hs | 76 +++++++++- 8 files changed, 199 insertions(+), 66 deletions(-) diff --git a/README.md b/README.md index e2bda24c..41088461 100644 --- a/README.md +++ b/README.md @@ -127,12 +127,12 @@ let setup = createTable #users ( serial `As` #id :* - (text & hasNotNull) `As` #name :* Nil ) + (text & notNullable) `As` #name :* Nil ) ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* - (int & hasNotNull) `As` #user_id :* - (text & hasNull) `As` #email :* Nil ) + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs index 051592d3..dc3f918f 100644 --- a/squeal-postgresql/exe/Example.hs +++ b/squeal-postgresql/exe/Example.hs @@ -45,14 +45,14 @@ setup :: Definition '[] Schema setup = createTable #users ( serial `As` #id :* - (text & hasNotNull) `As` #name :* - (vararray int2 & hasNotNull) `As` #vec :* Nil ) + (text & notNullable) `As` #name :* + (vararray int2 & notNullable) `As` #vec :* Nil ) ( primaryKey #id `As` #pk_users :* Nil ) >>> createTable #emails ( serial `As` #id :* - (int & hasNotNull) `As` #user_id :* - (text & hasNull) `As` #email :* Nil ) + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 78c1689a..4ce5fbcc 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -66,12 +66,12 @@ -- setup = -- createTable #users -- ( serial `As` #id :* --- (text & hasNotNull) `As` #name :* Nil ) +-- (text & notNullable) `As` #name :* Nil ) -- ( primaryKey #id `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* --- (int & hasNotNull) `As` #user_id :* --- (text & hasNull) `As` #email :* Nil ) +-- (int & notNullable) `As` #user_id :* +-- (text & nullable) `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 6efc21db..02fa2433 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -66,14 +66,15 @@ module Squeal.PostgreSQL.Definition , createView , dropView -- * Types - , createTypeComposite , createTypeEnum - , HasPGcomposite (..) - , HasPGenum (..) + , createTypeEnumWith + , createTypeComposite + , createTypeCompositeWith , dropType + -- * Columns , ColumnTypeExpression (..) - , hasNull - , hasNotNull + , nullable + , notNullable , default_ , serial2 , smallserial @@ -125,7 +126,7 @@ CREATE statements -- >>> :set -XOverloadedLabels -- >>> :{ -- renderDefinition $ --- createTable #tab ((int & hasNull) `As` #a :* (real & hasNull) `As` #b :* Nil) Nil +-- createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil -- :} -- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTable @@ -152,7 +153,7 @@ createTable tab columns constraints = UnsafeDefinition $ -- >>> type Schema = '["tab" ::: 'Table Table] -- >>> :{ -- renderDefinition --- (createTableIfNotExists #tab ((int & hasNull) `As` #a :* (real & hasNull) `As` #b :* Nil) Nil :: Definition Schema Schema) +-- (createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil :: Definition Schema Schema) -- :} -- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int NULL, \"b\" real NULL);" createTableIfNotExists @@ -234,8 +235,8 @@ newtype TableConstraintExpression -- let -- definition :: Definition '[] Schema -- definition = createTable #tab --- ( (int & hasNotNull) `As` #a :* --- (int & hasNotNull) `As` #b :* Nil ) +-- ( (int & notNullable) `As` #a :* +-- (int & notNullable) `As` #b :* Nil ) -- ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) -- :} -- @@ -265,8 +266,8 @@ check _cols condition = UnsafeTableConstraintExpression $ -- let -- definition :: Definition '[] Schema -- definition = createTable #tab --- ( (int & hasNull) `As` #a :* --- (int & hasNull) `As` #b :* Nil ) +-- ( (int & nullable) `As` #a :* +-- (int & nullable) `As` #b :* Nil ) -- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) -- :} -- @@ -297,7 +298,7 @@ unique columns = UnsafeTableConstraintExpression $ -- definition :: Definition '[] Schema -- definition = createTable #tab -- ( serial `As` #id :* --- (text & hasNotNull) `As` #name :* Nil ) +-- (text & notNullable) `As` #name :* Nil ) -- ( primaryKey #id `As` #pk_id :* Nil ) -- :} -- @@ -341,12 +342,12 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- setup = -- createTable #users -- ( serial `As` #id :* --- (text & hasNotNull) `As` #name :* Nil ) +-- (text & notNullable) `As` #name :* Nil ) -- ( primaryKey #id `As` #pk_users :* Nil ) >>> -- createTable #emails -- ( serial `As` #id :* --- (int & hasNotNull) `As` #user_id :* --- (text & hasNull) `As` #email :* Nil ) +-- (int & notNullable) `As` #user_id :* +-- (text & nullable) `As` #email :* Nil ) -- ( primaryKey #id `As` #pk_emails :* -- foreignKey #user_id #users #id -- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) @@ -375,8 +376,8 @@ primaryKey columns = UnsafeTableConstraintExpression $ -- setup = -- createTable #employees -- ( serial `As` #id :* --- (text & hasNotNull) `As` #name :* --- (integer & hasNull) `As` #employer_id :* Nil ) +-- (text & notNullable) `As` #name :* +-- (integer & nullable) `As` #employer_id :* Nil ) -- ( primaryKey #id `As` #employees_pk :* -- foreignKey #employer_id #employees #id -- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) @@ -409,6 +410,7 @@ foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ <+> renderOnDeleteClause ondel <+> renderOnUpdateClause onupd +-- | A constraint synonym between types involved in a foreign key constraint. type ForeignKeyed schema child parent table reftable @@ -578,7 +580,7 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & hasNull & default_ "foo")) + -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL DEFAULT E'foo';" @@ -590,7 +592,7 @@ class AddColumn ty where -- '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] - -- definition = alterTable #tab (addColumn #col2 (text & hasNull)) + -- definition = alterTable #tab (addColumn #col2 (text & nullable)) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL;" @@ -749,14 +751,15 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])] -- definition = --- alterTable #tab (alterColumn #col (alterType (numeric & hasNotNull))) +-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) -- in renderDefinition definition -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;" alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty --- | create a view... +-- | Create a view. +-- -- >>> :{ -- let -- definition :: Definition @@ -778,12 +781,28 @@ createView alias query = UnsafeDefinition $ "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS" <+> renderQuery query <> ";" +-- | Drop a view. +-- +-- >>> :{ +-- let +-- definition :: Definition +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) +-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] +-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])] +-- definition = dropView #bc +-- in renderDefinition definition +-- :} +-- "DROP VIEW \"bc\";" dropView :: Has view schema ('View v) => Alias view -- ^ view to remove -> Definition schema (Drop view schema) dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" +-- | Enumerated types are created using the `createTypeEnum` command, for example +-- +-- >>> renderDefinition $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +-- "CREATE TYPE \"mood\" AS ('sad', 'ok', 'happy');" createTypeEnum :: (KnownSymbol enum, SOP.All KnownSymbol labels) => Alias enum @@ -793,17 +812,29 @@ createTypeEnum enum labels = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> parenthesized (commaSeparated (renderLabels labels)) <> ";" -class - ( SOP.IsEnumType hask +-- | Enumerated types can also be generated from a Haskell type, for example +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance SOP.Generic Schwarma +-- >>> instance SOP.HasDatatypeInfo Schwarma +-- >>> renderDefinition $ createTypeEnumWith @Schwarma #schwarma +-- "CREATE TYPE \"schwarma\" AS ('Beef', 'Lamb', 'Chicken');" +createTypeEnumWith + :: forall hask enum schema. + ( SOP.Generic hask , SOP.All KnownSymbol (LabelsWith hask) - ) => HasPGenum hask where - createTypeEnumWith - :: KnownSymbol enum - => Alias enum - -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema) - createTypeEnumWith enum = createTypeEnum enum - (SOP.hpure label :: NP PGlabel (LabelsWith hask)) + , KnownSymbol enum + ) + => Alias enum + -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema) +createTypeEnumWith enum = createTypeEnum enum + (SOP.hpure label :: NP PGlabel (LabelsWith hask)) +-- | `createTypeComposite` creates a composite type. The composite type is +-- specified by a list of attribute names and data types. +-- +-- >>> renderDefinition $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) +-- "CREATE TYPE \"complex\" AS (float8 AS \"real\", float8 AS \"imaginary\");" createTypeComposite :: (KnownSymbol ty, SOP.SListI fields) => Alias ty @@ -813,19 +844,33 @@ createTypeComposite ty fields = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";" -class +-- | Composite types can also be generated from a Haskell type, for example +-- +-- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic +-- >>> instance SOP.Generic Complex +-- >>> instance SOP.HasDatatypeInfo Complex +-- >>> renderDefinition $ createTypeCompositeWith @Complex #complex +-- "CREATE TYPE \"complex\" AS (float8 AS \"real\", float8 AS \"imaginary\");" +createTypeCompositeWith + :: forall hask ty schema. ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask) , SOP.All PGTyped (FieldTypesWith hask) - ) => HasPGcomposite hask where - createTypeCompositeWith - :: KnownSymbol ty - => Alias ty - -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema) - createTypeCompositeWith ty = createTypeComposite ty $ zipAs - (SOP.hpure Alias :: NP Alias (FieldNamesWith hask)) - (SOP.hcpure (SOP.Proxy :: SOP.Proxy PGTyped) pgtype - :: NP TypeExpression (FieldTypesWith hask)) + , KnownSymbol ty + ) + => Alias ty + -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema) +createTypeCompositeWith ty = createTypeComposite ty $ zipAs + (SOP.hpure Alias :: NP Alias (FieldNamesWith hask)) + (SOP.hcpure (SOP.Proxy :: SOP.Proxy PGTyped) pgtype + :: NP TypeExpression (FieldTypesWith hask)) +-- | Drop a type. +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance SOP.Generic Schwarma +-- >>> instance SOP.HasDatatypeInfo Schwarma +-- >>> renderDefinition (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[]) +-- "DROP TYPE \"schwarma\";" dropType :: Has tydef schema ('Typedef ty) => Alias tydef @@ -841,17 +886,19 @@ instance (Has alias schema ('Typedef ty)) => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias)) -hasNull +-- | used in `createTable` commands as a column constraint to note that +-- @NULL@ may be present in a column +nullable :: TypeExpression ty -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) -hasNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" +nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" -- | used in `createTable` commands as a column constraint to ensure --- @NULL@ is not present -hasNotNull +-- @NULL@ is not present in a column +notNullable :: TypeExpression ty -> ColumnTypeExpression schema (def :=> 'NotNull ty) -hasNotNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" +notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" -- | used in `createTable` commands as a column constraint to give a default default_ diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index cb7a9c9f..24740e02 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -40,7 +40,7 @@ module Squeal.PostgreSQL.Expression , isNotNull , matchNull , nullIf - -- ** Arrays, Enums, Composites + -- ** Collections , array , row -- ** Functions @@ -366,9 +366,17 @@ instance (KnownSymbol label, label `In` labels) => IsPGlabel label (Expression relations grouping params (nullity ('PGenum labels))) where label = UnsafeExpression $ renderLabel (PGlabel @label) +-- | A row constructor is an expression that builds a row value +-- (also called a composite value) using values for its member fields. +-- +-- >>> type Complex = PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8] +-- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] 'Ungrouped '[] ('NotNull Complex) +-- >>> renderExpression i +-- "ROW(0, 1)" row - :: (SListI (Nulls fields)) + :: SListI (Nulls fields) => NP (Aliased (Expression relation grouping params)) (Nulls fields) + -- ^ zero or more expressions for the row field values -> Expression relation grouping params (nullity ('PGcomposite fields)) row exprs = UnsafeExpression $ "ROW" <> parenthesized (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs index 252ce99e..c8610541 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs @@ -37,7 +37,7 @@ let , up = void . define $ createTable #users ( serial `As` #id :* - (text & hasNotNull) `As` #name :* Nil ) + (text & notNullable) `As` #name :* Nil ) ( primaryKey #id `As` #pk_users :* Nil ) , down = void . define $ dropTable #users } @@ -52,8 +52,8 @@ let , up = void . define $ createTable #emails ( serial `As` #id :* - (int & hasNotNull) `As` #user_id :* - (text & hasNull) `As` #email :* Nil ) + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) @@ -285,8 +285,8 @@ createMigrations => Definition schema schema createMigrations = createTableIfNotExists #schema_migrations - ( (text & hasNotNull) `As` #name :* - (timestampWithTimeZone & hasNotNull & default_ currentTimestamp) + ( (text & notNullable) `As` #name :* + (timestampWithTimeZone & notNullable & default_ currentTimestamp) `As` #executed_at :* Nil ) ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil ) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 6dcc7630..0bf7c567 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -426,10 +426,20 @@ selectDistinctDotStar rel relations = UnsafeQuery $ "SELECT DISTINCT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations +-- | `values` computes a row value or set of row values +-- specified by value expressions. It is most commonly used +-- to generate a “constant table” within a larger command, +-- but it can be used on its own. +-- +-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext] +-- >>> let query = values (1 `As` #a :* "one" `As` #b :* Nil) [] :: Query '[] '[] Row +-- >>> renderQuery query +-- "SELECT * FROM (VALUES (1, E'one')) AS t (\"a\", \"b\")" values :: SListI cols => NP (Aliased (Expression '[] 'Ungrouped params)) cols -> [NP (Aliased (Expression '[] 'Ungrouped params)) cols] + -- ^ When more than one row is specified, all the rows must -> Query schema params cols values rw rws = UnsafeQuery $ "SELECT * FROM" <+> parenthesized ( diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 74e53a8f..21ddd6f4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -328,6 +328,7 @@ type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where type family TableToColumns (table :: TableType) :: ColumnsType where TableToColumns (constraints :=> columns) = columns +-- | Convert a table to a relation. type family TableToRelation (table :: TableType) :: RelationType where TableToRelation tab = ColumnsToRelation (TableToColumns tab) @@ -414,6 +415,12 @@ type family AliasesOf aliaseds where AliasesOf '[] = '[] AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys +-- | The `ZipAliased` class provides a type family for zipping +-- `Symbol` lists together with arbitrary lists of the same size, +-- with an associated type family `ZipAs`, together with +-- a method `zipAs` for zipping heterogeneous lists of `Alias`es +-- together with a heterogeneous list of expressions into +-- a heterogeneous list of `Aliased` expressions. class ( SListI (ZipAs ns xs) , All KnownSymbol ns @@ -443,7 +450,8 @@ instance type HasUnique alias fields field = fields ~ '[alias ::: field] -- | @Has alias fields field@ is a constraint that proves that --- @fields@ has a field of @alias ::: field@. +-- @fields@ has a field of @alias ::: field@, inferring @field@ +-- from @alias@ and @fields@. class KnownSymbol alias => Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) | alias fields -> field where @@ -452,6 +460,8 @@ instance {-# OVERLAPPING #-} KnownSymbol alias instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field) => Has alias (field' ': fields) field +-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer +-- a list of @subfields@. class ( All KnownSymbol aliases ) => HasAll @@ -509,6 +519,7 @@ type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType) SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1) = (ty0 ~ ty1, SameTypes columns0 columns1) +-- | Equality constraint on the underlying `PGType` of two columns. class SamePGType (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where instance ty0 ~ ty1 => SamePGType @@ -596,6 +607,7 @@ type family Rename alias0 alias1 xs where Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs +-- | `MapMaybes` is used in the binary instances of composite types. class MapMaybes xs where type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs maybes :: NP Maybe xs -> NP I (Maybes xs) @@ -609,6 +621,8 @@ instance MapMaybes xs => MapMaybes (x ': xs) where maybes (x :* xs) = I x :* maybes xs unMaybes (I mx :* xs) = mx :* unMaybes xs +-- | `Nulls` is used to construct a `Squeal.Postgresql.Expression.row` +-- of a composite type. type family Nulls tys where Nulls '[] = '[] Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys @@ -676,7 +690,7 @@ type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss -- | The `PG` type family embeds a subset of Haskell types --- as basic Postgres types. +-- as Postgres basic types. -- -- >>> :kind! PG LocalTime -- PG LocalTime :: PGType @@ -707,25 +721,67 @@ type family PG (hask :: Type) :: PGType where PG (NetAddr IP) = 'PGinet PG Value = 'PGjson PG ty = TypeError - ('Text "There is no basic Postgres type for " ':<>: 'ShowType ty) + ('Text "There is no Postgres basic type for " ':<>: 'ShowType ty) +-- | The `EnumWith` type family embeds Haskell enum types, ADTs with +-- nullary constructors, as Postgres enum types +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance Generic Schwarma +-- >>> instance HasDatatypeInfo Schwarma +-- >>> :kind! EnumWith Schwarma +-- EnumWith Schwarma :: PGType +-- = 'PGenum '["Beef", "Lamb", "Chicken"] type family EnumWith (hask :: Type) :: PGType where EnumWith hask = 'PGenum (LabelsWith hask) +-- | The `LabelsWith` type family calculates the constructors of a +-- Haskell enum type. +-- +-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +-- >>> instance Generic Schwarma +-- >>> instance HasDatatypeInfo Schwarma +-- >>> :kind! LabelsWith Schwarma +-- LabelsWith Schwarma :: [Type.ConstructorName] +-- = '["Beef", "Lamb", "Chicken"] type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where LabelsWith hask = ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask)) +-- | The `CompositeWith` type family embeds Haskell record types as +-- Postgres composite types, as long as the record fields +-- are `Maybe`s of Haskell types that can be embedded as basic types +-- with the `PG` type family. +-- +-- >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic +-- >>> instance Generic Row +-- >>> instance HasDatatypeInfo Row +-- >>> :kind! CompositeWith Row +-- CompositeWith Row :: PGType +-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)] type family CompositeWith (hask :: Type) :: PGType where CompositeWith hask = 'PGcomposite (ZipAs (FieldNamesWith hask) (FieldTypesWith hask)) +-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic +-- >>> instance Generic Row +-- >>> instance HasDatatypeInfo Row +-- >>> :kind! FieldNamesWith Row +-- FieldNamesWith Row :: [Type.FieldName] +-- = '["a", "b"] type family FieldNamesWith (hask :: Type) :: [Type.FieldName] where FieldNamesWith hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask)) +-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic +-- >>> instance Generic Row +-- >>> instance HasDatatypeInfo Row +-- >>> :kind! FieldTypesWith Row +-- FieldTypesWith Row :: [PGType] +-- = '['PGint2, 'PGtimestamp] type family FieldTypesWith (hask :: Type) :: [PGType] where FieldTypesWith hask = FieldTypesOf (RecordCodeOf hask (Code hask)) +-- | Calculates constructors of a datatype. type family ConstructorsOf (datatype :: Type.DatatypeInfo) :: [Type.ConstructorInfo] where ConstructorsOf ('Type.ADT _module _datatype constructors) = @@ -733,6 +789,8 @@ type family ConstructorsOf (datatype :: Type.DatatypeInfo) ConstructorsOf ('Type.Newtype _module _datatype constructor) = '[constructor] +-- | Calculates the name of a nullary constructor, otherwise +-- generates a type error. type family ConstructorNameOf (constructors :: Type.ConstructorInfo) :: Type.ConstructorName where ConstructorNameOf ('Type.Constructor name) = name @@ -743,36 +801,46 @@ type family ConstructorNameOf (constructors :: Type.ConstructorInfo) ('Text "ConstructorNameOf error: non-nullary constructor " ':<>: 'Text name) +-- | Calculate the names of nullary constructors. type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo]) :: [Type.ConstructorName] where ConstructorNamesOf '[] = '[] ConstructorNamesOf (constructor ': constructors) = ConstructorNameOf constructor ': ConstructorNamesOf constructors -type family FieldsOf (constructor :: Type.DatatypeInfo) +-- | Calculate the fields of a datatype. +type family FieldsOf (datatype :: Type.DatatypeInfo) :: [Type.FieldInfo] where FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) = fields FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) = fields +-- | Calculate the name of a field. type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where FieldNameOf ('Type.FieldInfo name) = name +-- | Calculate the names of fields. type family FieldNamesOf (fields :: [Type.FieldInfo]) :: [Type.FieldName] where FieldNamesOf '[] = '[] FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields +-- | >>> :kind! FieldTypeOf (Maybe Int16) +-- FieldTypeOf (Maybe Int16) :: PGType +-- = 'PGint2 type family FieldTypeOf (maybe :: Type) where FieldTypeOf (Maybe hask) = PG hask FieldTypeOf ty = TypeError ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty) +-- | Calculate the types of fields. type family FieldTypesOf (fields :: [Type]) where FieldTypesOf '[] = '[] FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields +-- | Inspect the code of an algebraic datatype and ensure it's a product, +-- otherwise generate a type error type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where RecordCodeOf _hask '[tys] = tys RecordCodeOf hask _tys = TypeError From 1b0f63a6f2b35a9ef1e8b16759ce657115ce90ba Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 11:07:41 -0700 Subject: [PATCH 45/92] argument docstrings --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 02fa2433..a6933ca5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -806,7 +806,9 @@ dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" createTypeEnum :: (KnownSymbol enum, SOP.All KnownSymbol labels) => Alias enum + -- ^ name of the user defined enumerated type -> NP PGlabel labels + -- ^ labels of the enumerated type -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) createTypeEnum enum labels = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> @@ -826,6 +828,7 @@ createTypeEnumWith , KnownSymbol enum ) => Alias enum + -- ^ name of the user defined enumerated type -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema) createTypeEnumWith enum = createTypeEnum enum (SOP.hpure label :: NP PGlabel (LabelsWith hask)) @@ -838,7 +841,9 @@ createTypeEnumWith enum = createTypeEnum enum createTypeComposite :: (KnownSymbol ty, SOP.SListI fields) => Alias ty + -- ^ name of the user defined composite type -> NP (Aliased TypeExpression) fields + -- ^ list of attribute names and data types -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema) createTypeComposite ty fields = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized @@ -858,6 +863,7 @@ createTypeCompositeWith , KnownSymbol ty ) => Alias ty + -- ^ name of the user defined composite type -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema) createTypeCompositeWith ty = createTypeComposite ty $ zipAs (SOP.hpure Alias :: NP Alias (FieldNamesWith hask)) @@ -874,6 +880,7 @@ createTypeCompositeWith ty = createTypeComposite ty $ zipAs dropType :: Has tydef schema ('Typedef ty) => Alias tydef + -- ^ name of the user defined type -> Definition schema (Drop tydef schema) dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";" From 5709105306945d8c02b4467ae3a322f56f16ba43 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 11:16:10 -0700 Subject: [PATCH 46/92] argument strings --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index a6933ca5..5f21e370 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -246,7 +246,9 @@ check :: ( Has alias schema ('Table table) , HasAll aliases (TableToRelation table) subcolumns ) => NP Alias aliases + -- ^ specify the subcolumns which are getting checked -> (forall tab. Condition '[tab ::: subcolumns] 'Ungrouped '[]) + -- ^ a closed `Condition` on those subcolumns -> TableConstraintExpression schema alias ('Check aliases) check _cols condition = UnsafeTableConstraintExpression $ "CHECK" <+> parenthesized (renderExpression condition) @@ -277,6 +279,7 @@ unique :: ( Has alias schema ('Table table) , HasAll aliases (TableToRelation table) subcolumns ) => NP Alias aliases + -- ^ specify subcolumns which together are unique for each row -> TableConstraintExpression schema alias ('Unique aliases) unique columns = UnsafeTableConstraintExpression $ "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns)) @@ -309,6 +312,7 @@ primaryKey , HasAll aliases (TableToColumns table) subcolumns , AllNotNull subcolumns ) => NP Alias aliases + -- ^ specify the subcolumns which together form a primary key. -> TableConstraintExpression schema alias ('PrimaryKey aliases) primaryKey columns = UnsafeTableConstraintExpression $ "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns)) From c674451adac79dd3de9dc9a3df4cbc03e5b93e12 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 11:19:42 -0700 Subject: [PATCH 47/92] organization --- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 5f21e370..ebb0744b 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -28,10 +28,11 @@ Squeal data definition language. #-} module Squeal.PostgreSQL.Definition - ( -- * Definition + ( -- * Definition Definition (UnsafeDefinition, renderDefinition) , (>>>) - -- * Create + -- * Tables + -- ** Create , createTable , createTableIfNotExists , TableConstraintExpression (..) @@ -44,9 +45,9 @@ module Squeal.PostgreSQL.Definition , renderOnDeleteClause , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade) , renderOnUpdateClause - -- * Drop + -- ** Drop , dropTable - -- * Alter + -- ** Alter , alterTable , alterTableRename , AlterTable (UnsafeAlterTable, renderAlterTable) From c41c2842dc696c789986e2fc8dbd8f91668f7fd4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 11:26:36 -0700 Subject: [PATCH 48/92] update cabal file --- squeal-postgresql/squeal-postgresql.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index fc9c228a..6d03a9e2 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -1,5 +1,5 @@ name: squeal-postgresql -version: 0.2.1.0 +version: 0.3.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal @@ -38,8 +38,8 @@ library build-depends: aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 - , binary-parser - , bytestring-strict-builder + , binary-parser >= 0.5.5 + , bytestring-strict-builder >= 0.4.5 , bytestring >= 0.10.8.2 , deepseq >= 1.4.3.0 , generics-sop >= 0.3.2.0 From 06033d9aaefc6c09b920e365125fb15818f0c3f4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 3 Jun 2018 13:58:23 -0700 Subject: [PATCH 49/92] Found some issues with `TypeExpression`s and `ColumnTypeExpression`s that have to be resolved --- .../src/Squeal/PostgreSQL/Binary.hs | 60 +++++++++++++++++++ .../src/Squeal/PostgreSQL/Definition.hs | 2 +- .../src/Squeal/PostgreSQL/Query.hs | 11 ++++ 3 files changed, 72 insertions(+), 1 deletion(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 95a05af9..a8d2afa4 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -6,6 +6,66 @@ Maintainer: eitan@morphism.tech Stability: experimental Binary encoding and decoding between Haskell and PostgreSQL types. + +Instances are governed by the `Generic` and `HasDatatype` typeclasses. + +>>> import Control.Monad +>>> import Control.Monad.Base + +>>> import Squeal.PostgreSQL + +>>> data Schwarma = Beef | Lamb | Chicken deriving (Show, GHC.Generic) +>>> instance Generic Schwarma +>>> instance HasDatatypeInfo Schwarma + +>>> let q = values_ (label @"Beef" `As` #fromOnly :* Nil) :: Query '[] '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] + +>>> :{ +void . withConnection "host=localhost port=5432 dbname=exampledb" $ do + result <- runQuery q + Just (Only schwarma) <- firstRow result + liftBase $ print (schwarma :: Schwarma) +:} +Beef + +>>> :{ +type family Schema :: SchemaType where + Schema = + '[ "schwarma" ::: 'Typedef (EnumWith Schwarma) + , "tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull (EnumWith Schwarma)]) + ] +:} + +>>> :{ +let + setup = + createTypeEnumWith @Schwarma #schwarma >>> + createTable #tab (#schwarma `As` #col :* Nil) Nil + :: Definition '[] Schema + teardown = + dropTable #tab >>> + dropType #schwarma + :: Definition Schema '[] + manip = + insertRow_ #tab (Set (param @1) `As` #col :* Nil) + :: Manipulation Schema '[ 'NotNull (EnumWith Schwarma)] '[] + qry = + select (#col `As` #fromOnly :* Nil) (from (table #tab)) + :: Query Schema '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] + session = do + manipulateParams manip (Only Chicken) + result <- runQuery qry + Just (Only schwarma) <- firstRow result + liftBase $ print (schwarma :: Schwarma) +:} + +>>> :{ +void . withConnection "host=localhost port=5432 dbname=exampledb" $ + define setup + & pqThen session + & pqThen (define teardown) +:} +Chicken -} {-# LANGUAGE diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index ebb0744b..689a0ff1 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -896,7 +896,7 @@ newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType) instance (Has alias schema ('Typedef ty)) => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where - fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias)) + fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias) <+> "NOT NULL") -- | used in `createTable` commands as a column constraint to note that -- @NULL@ may be present in a column diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 0bf7c567..889b41cd 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -37,6 +37,7 @@ module Squeal.PostgreSQL.Query , selectDotStar , selectDistinctDotStar , values + , values_ -- * Table Expressions , TableExpression (..) , renderTableExpression @@ -440,6 +441,7 @@ values => NP (Aliased (Expression '[] 'Ungrouped params)) cols -> [NP (Aliased (Expression '[] 'Ungrouped params)) cols] -- ^ When more than one row is specified, all the rows must + -- must have the same number of elements -> Query schema params cols values rw rws = UnsafeQuery $ "SELECT * FROM" <+> parenthesized ( @@ -455,6 +457,15 @@ values rw rws = UnsafeQuery $ "SELECT * FROM" renderAliasPart (_ `As` name) = renderAlias name renderValuePart (value `As` _) = renderExpression value +-- | `values_` computes a row value or set of row values +-- specified by value expressions. +values_ + :: SListI cols + => NP (Aliased (Expression '[] 'Ungrouped params)) cols + -- ^ one row of values + -> Query schema params cols +values_ rw = values rw [] + {----------------------------------------- Table Expressions -----------------------------------------} From a174b797923d222b607bbf27dcfbefee95a33788 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 7 Jun 2018 17:54:30 -0700 Subject: [PATCH 50/92] failing test I think it arises from incomplete kinds for Expression and TypeExpression --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index a8d2afa4..4b29781d 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -13,6 +13,7 @@ Instances are governed by the `Generic` and `HasDatatype` typeclasses. >>> import Control.Monad.Base >>> import Squeal.PostgreSQL +>>> import qualified Squeal.PostgreSQL as SQL >>> data Schwarma = Beef | Lamb | Chicken deriving (Show, GHC.Generic) >>> instance Generic Schwarma @@ -28,6 +29,7 @@ void . withConnection "host=localhost port=5432 dbname=exampledb" $ do :} Beef +>>> :set -XTypeFamilies -XTypeInType -XUndecidableInstances >>> :{ type family Schema :: SchemaType where Schema = @@ -50,7 +52,7 @@ let insertRow_ #tab (Set (param @1) `As` #col :* Nil) :: Manipulation Schema '[ 'NotNull (EnumWith Schwarma)] '[] qry = - select (#col `As` #fromOnly :* Nil) (from (table #tab)) + select (#col `As` #fromOnly :* Nil) (SQL.from (table #tab)) :: Query Schema '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] session = do manipulateParams manip (Only Chicken) From 6e5f5f53a5cc7f567d9a85b54b59f17dcbafa309 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 7 Jun 2018 19:39:34 -0700 Subject: [PATCH 51/92] push through adding schema kind to Expression, TypeExpression, etc. --- .../src/Squeal/PostgreSQL/Definition.hs | 22 +- .../src/Squeal/PostgreSQL/Expression.hs | 486 +++++++++--------- .../src/Squeal/PostgreSQL/Manipulation.hs | 78 +-- .../src/Squeal/PostgreSQL/Query.hs | 78 +-- 4 files changed, 338 insertions(+), 326 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 689a0ff1..427c27bd 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -248,7 +248,7 @@ check , HasAll aliases (TableToRelation table) subcolumns ) => NP Alias aliases -- ^ specify the subcolumns which are getting checked - -> (forall tab. Condition '[tab ::: subcolumns] 'Ungrouped '[]) + -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[]) -- ^ a closed `Condition` on those subcolumns -> TableConstraintExpression schema alias ('Check aliases) check _cols condition = UnsafeTableConstraintExpression $ @@ -695,7 +695,7 @@ newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnTyp -- :} -- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET DEFAULT 5;" setDefault - :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set + :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set -> AlterColumn schema (constraint :=> ty) ('Def :=> ty) setDefault expression = UnsafeAlterColumn $ "SET DEFAULT" <+> renderExpression expression @@ -847,7 +847,7 @@ createTypeComposite :: (KnownSymbol ty, SOP.SListI fields) => Alias ty -- ^ name of the user defined composite type - -> NP (Aliased TypeExpression) fields + -> NP (Aliased (TypeExpression schema)) fields -- ^ list of attribute names and data types -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema) createTypeComposite ty fields = UnsafeDefinition $ @@ -864,7 +864,7 @@ createTypeComposite ty fields = UnsafeDefinition $ createTypeCompositeWith :: forall hask ty schema. ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask) - , SOP.All PGTyped (FieldTypesWith hask) + , SOP.All (PGTyped schema) (FieldTypesWith hask) , KnownSymbol ty ) => Alias ty @@ -872,8 +872,8 @@ createTypeCompositeWith -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema) createTypeCompositeWith ty = createTypeComposite ty $ zipAs (SOP.hpure Alias :: NP Alias (FieldNamesWith hask)) - (SOP.hcpure (SOP.Proxy :: SOP.Proxy PGTyped) pgtype - :: NP TypeExpression (FieldTypesWith hask)) + (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype + :: NP (TypeExpression schema) (FieldTypesWith hask)) -- | Drop a type. -- @@ -894,27 +894,23 @@ newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType) = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance (Has alias schema ('Typedef ty)) - => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where - fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias) <+> "NOT NULL") - -- | used in `createTable` commands as a column constraint to note that -- @NULL@ may be present in a column nullable - :: TypeExpression ty + :: TypeExpression schema ty -> ColumnTypeExpression schema ('NoDef :=> 'Null ty) nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL" -- | used in `createTable` commands as a column constraint to ensure -- @NULL@ is not present in a column notNullable - :: TypeExpression ty + :: TypeExpression schema ty -> ColumnTypeExpression schema (def :=> 'NotNull ty) notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL" -- | used in `createTable` commands as a column constraint to give a default default_ - :: Expression '[] 'Ungrouped '[] ty + :: Expression schema '[] 'Ungrouped '[] ty -> ColumnTypeExpression schema ('NoDef :=> ty) -> ColumnTypeExpression schema ('Def :=> ty) default_ x ty = UnsafeColumnTypeExpression $ diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index 24740e02..b13afadf 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -30,7 +30,8 @@ Squeal expressions are the atoms used to build statements. module Squeal.PostgreSQL.Expression ( -- * Expression Expression (UnsafeExpression, renderExpression) - , HasParameter (param) + , HasParameter (parameter) + , param -- ** Null , null_ , notNull @@ -163,6 +164,7 @@ values from primitive expression using arithmetic, logical, and other operations. -} newtype Expression + (schema :: SchemaType) (relations :: RelationsType) (grouping :: Grouping) (params :: [NullityType]) @@ -178,43 +180,51 @@ supplied externally to a SQL statement. separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -} -class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter +class KnownNat n => HasParameter (n :: Nat) + (schema :: SchemaType) (params :: [NullityType]) (ty :: NullityType) | n params -> ty where - param :: Expression relations grouping params ty - param = UnsafeExpression $ parenthesized $ + parameter + :: TypeExpression schema (PGTypeOf ty) + -> Expression schema relations grouping params ty + parameter ty = UnsafeExpression $ parenthesized $ "$" <> renderNat (Proxy @n) <+> "::" - <+> renderTypeExpression (pgtype @(PGTypeOf ty)) -instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1) - => HasParameter 1 (ty1:tys) ty1 -instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty) - => HasParameter n (ty' : params) ty + <+> renderTypeExpression ty +instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1 +instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty) + => HasParameter n schema (ty' : params) ty + +param + :: forall n schema params relations grouping ty + . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty) + => Expression schema relations grouping params ty +param = parameter @n pgtype instance (HasUnique relation relations columns, Has column columns ty) - => IsLabel column (Expression relations 'Ungrouped params ty) where + => IsLabel column (Expression schema relations 'Ungrouped params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) instance (HasUnique relation relations columns, Has column columns ty) => IsLabel column - (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where + (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where fromLabel = fromLabel @column `As` Alias @column instance (HasUnique relation relations columns, Has column columns ty) => IsLabel column - (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where + (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where fromLabel = fromLabel @column :* Nil instance (Has relation relations columns, Has column columns ty) - => IsQualified relation column (Expression relations 'Ungrouped params ty) where + => IsQualified relation column (Expression schema relations 'Ungrouped params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column instance (Has relation relations columns, Has column columns ty) => IsQualified relation column - (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where + (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where relation ! column = relation ! column `As` column instance (Has relation relations columns, Has column columns ty) => IsQualified relation column - (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where + (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where relation ! column = relation ! column :* Nil instance @@ -222,14 +232,14 @@ instance , Has column columns ty , GroupedBy relation column bys ) => IsLabel column - (Expression relations ('Grouped bys) params ty) where + (Expression schema relations ('Grouped bys) params ty) where fromLabel = UnsafeExpression $ renderAlias (Alias @column) instance ( HasUnique relation relations columns , Has column columns ty , GroupedBy relation column bys ) => IsLabel column - ( Aliased (Expression relations ('Grouped bys) params) + ( Aliased (Expression schema relations ('Grouped bys) params) (column ::: ty) ) where fromLabel = fromLabel @column `As` Alias @column instance @@ -237,7 +247,7 @@ instance , Has column columns ty , GroupedBy relation column bys ) => IsLabel column - ( NP (Aliased (Expression relations ('Grouped bys) params)) + ( NP (Aliased (Expression schema relations ('Grouped bys) params)) '[column ::: ty] ) where fromLabel = fromLabel @column :* Nil @@ -246,7 +256,7 @@ instance , Has column columns ty , GroupedBy relation column bys ) => IsQualified relation column - (Expression relations ('Grouped bys) params ty) where + (Expression schema relations ('Grouped bys) params ty) where relation ! column = UnsafeExpression $ renderAlias relation <> "." <> renderAlias column instance @@ -254,7 +264,7 @@ instance , Has column columns ty , GroupedBy relation column bys ) => IsQualified relation column - (Aliased (Expression relations ('Grouped bys) params) + (Aliased (Expression schema relations ('Grouped bys) params) (column ::: ty)) where relation ! column = relation ! column `As` column instance @@ -262,7 +272,7 @@ instance , Has column columns ty , GroupedBy relation column bys ) => IsQualified relation column - ( NP (Aliased (Expression relations ('Grouped bys) params)) + ( NP (Aliased (Expression schema relations ('Grouped bys) params)) '[column ::: ty]) where relation ! column = relation ! column :* Nil @@ -270,7 +280,7 @@ instance -- -- >>> renderExpression $ null_ -- "NULL" -null_ :: Expression rels grouping params ('Null ty) +null_ :: Expression schema rels grouping params ('Null ty) null_ = UnsafeExpression "NULL" -- | analagous to `Just` @@ -278,8 +288,8 @@ null_ = UnsafeExpression "NULL" -- >>> renderExpression $ notNull true -- "TRUE" notNull - :: Expression rels grouping params ('NotNull ty) - -> Expression rels grouping params ('Null ty) + :: Expression schema rels grouping params ('NotNull ty) + -> Expression schema rels grouping params ('Null ty) notNull = UnsafeExpression . renderExpression -- | return the leftmost value which is not NULL @@ -287,11 +297,11 @@ notNull = UnsafeExpression . renderExpression -- >>> renderExpression $ coalesce [null_, notNull true] false -- "COALESCE(NULL, TRUE, FALSE)" coalesce - :: [Expression relations grouping params ('Null ty)] + :: [Expression schema relations grouping params ('Null ty)] -- ^ @NULL@s may be present - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('NotNull ty) coalesce nullxs notNullx = UnsafeExpression $ "COALESCE" <> parenthesized (commaSeparated ((renderExpression <$> nullxs) <> [renderExpression notNullx])) @@ -301,26 +311,26 @@ coalesce nullxs notNullx = UnsafeExpression $ -- >>> renderExpression $ fromNull true null_ -- "COALESCE(NULL, TRUE)" fromNull - :: Expression relations grouping params ('NotNull ty) + :: Expression schema relations grouping params ('NotNull ty) -- ^ what to convert @NULL@ to - -> Expression relations grouping params ('Null ty) - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('Null ty) + -> Expression schema relations grouping params ('NotNull ty) fromNull notNullx nullx = coalesce [nullx] notNullx -- | >>> renderExpression $ null_ & isNull -- "NULL IS NULL" isNull - :: Expression relations grouping params ('Null ty) + :: Expression schema relations grouping params ('Null ty) -- ^ possibly @NULL@ - -> Condition relations grouping params + -> Condition schema relations grouping params isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL" -- | >>> renderExpression $ null_ & isNotNull -- "NULL IS NOT NULL" isNotNull - :: Expression relations grouping params ('Null ty) + :: Expression schema relations grouping params ('Null ty) -- ^ possibly @NULL@ - -> Condition relations grouping params + -> Condition schema relations grouping params isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@ @@ -328,13 +338,13 @@ isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" -- >>> renderExpression $ matchNull true not_ null_ -- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END" matchNull - :: Expression relations grouping params (nullty) + :: Expression schema relations grouping params (nullty) -- ^ what to convert @NULL@ to - -> ( Expression relations grouping params ('NotNull ty) - -> Expression relations grouping params (nullty) ) + -> ( Expression schema relations grouping params ('NotNull ty) + -> Expression schema relations grouping params (nullty) ) -- ^ function to perform when @NULL@ is absent - -> Expression relations grouping params ('Null ty) - -> Expression relations grouping params (nullty) + -> Expression schema relations grouping params ('Null ty) + -> Expression schema relations grouping params (nullty) matchNull y f x = ifThenElse (isNull x) y (f (UnsafeExpression (renderExpression x))) @@ -345,25 +355,25 @@ matchNull y f x = ifThenElse (isNull x) y -- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1)) -- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)" nullIf - :: Expression relations grouping params ('NotNull ty) + :: Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent - -> Expression relations grouping params ('NotNull ty) + -> Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent - -> Expression relations grouping params ('Null ty) + -> Expression schema relations grouping params ('Null ty) nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized (renderExpression x <> ", " <> renderExpression y) -- | >>> renderExpression $ array [null_, notNull false, notNull true] -- "ARRAY[NULL, FALSE, TRUE]" array - :: [Expression relations grouping params ('Null ty)] + :: [Expression schema relations grouping params ('Null ty)] -- ^ array elements - -> Expression relations grouping params (nullity ('PGvararray ty)) + -> Expression schema relations grouping params (nullity ('PGvararray ty)) array xs = UnsafeExpression $ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]" instance (KnownSymbol label, label `In` labels) => IsPGlabel label - (Expression relations grouping params (nullity ('PGenum labels))) where + (Expression schema relations grouping params (nullity ('PGenum labels))) where label = UnsafeExpression $ renderLabel (PGlabel @label) -- | A row constructor is an expression that builds a row value @@ -375,47 +385,47 @@ instance (KnownSymbol label, label `In` labels) => IsPGlabel label -- "ROW(0, 1)" row :: SListI (Nulls fields) - => NP (Aliased (Expression relation grouping params)) (Nulls fields) + => NP (Aliased (Expression schema relations grouping params)) (Nulls fields) -- ^ zero or more expressions for the row field values - -> Expression relation grouping params (nullity ('PGcomposite fields)) + -> Expression schema relations grouping params (nullity ('PGcomposite fields)) row exprs = UnsafeExpression $ "ROW" <> parenthesized (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs) instance Has field fields ty => IsLabel field - ( Expression relation grouping params (nullity ('PGcomposite fields)) - -> Expression relation grouping params ('Null ty) ) where + ( Expression schema relation grouping params (nullity ('PGcomposite fields)) + -> Expression schema relation grouping params ('Null ty) ) where fromLabel expr = UnsafeExpression $ parenthesized (renderExpression expr) <> "." <> fromString (symbolVal (Proxy @field)) instance Semigroup - (Expression relations grouping params (nullity ('PGvararray ty))) where + (Expression schema relations grouping params (nullity ('PGvararray ty))) where (<>) = unsafeBinaryOp "||" instance Monoid - (Expression relations grouping params (nullity ('PGvararray ty))) where + (Expression schema relations grouping params (nullity ('PGvararray ty))) where mempty = array [] mappend = (<>) -- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1] -- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))" greatest - :: Expression relations grouping params (nullty) + :: Expression schema relations grouping params (nullty) -- ^ needs at least 1 argument - -> [Expression relations grouping params (nullty)] + -> [Expression schema relations grouping params (nullty)] -- ^ or more - -> Expression relations grouping params (nullty) + -> Expression schema relations grouping params (nullty) greatest x xs = UnsafeExpression $ "GREATEST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" -- | >>> renderExpression $ least currentTimestamp [null_] -- "LEAST(CURRENT_TIMESTAMP, NULL)" least - :: Expression relations grouping params (nullty) + :: Expression schema relations grouping params (nullty) -- ^ needs at least 1 argument - -> [Expression relations grouping params (nullty)] + -> [Expression schema relations grouping params (nullty)] -- ^ or more - -> Expression relations grouping params (nullty) + -> Expression schema relations grouping params (nullty) least x xs = UnsafeExpression $ "LEAST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" @@ -424,9 +434,9 @@ least x xs = UnsafeExpression $ "LEAST(" unsafeBinaryOp :: ByteString -- ^ operator - -> Expression relations grouping params (ty0) - -> Expression relations grouping params (ty1) - -> Expression relations grouping params (ty2) + -> Expression schema relations grouping params (ty0) + -> Expression schema relations grouping params (ty1) + -> Expression schema relations grouping params (ty2) unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ renderExpression x <+> op <+> renderExpression y @@ -435,8 +445,8 @@ unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ unsafeUnaryOp :: ByteString -- ^ operator - -> Expression relations grouping params (ty0) - -> Expression relations grouping params (ty1) + -> Expression schema relations grouping params (ty0) + -> Expression schema relations grouping params (ty1) unsafeUnaryOp op x = UnsafeExpression $ parenthesized $ op <+> renderExpression x @@ -445,13 +455,13 @@ unsafeUnaryOp op x = UnsafeExpression $ parenthesized $ unsafeFunction :: ByteString -- ^ function - -> Expression relations grouping params (xty) - -> Expression relations grouping params (yty) + -> Expression schema relations grouping params (xty) + -> Expression schema relations grouping params (yty) unsafeFunction fun x = UnsafeExpression $ fun <> parenthesized (renderExpression x) instance PGNum ty - => Num (Expression relations grouping params (nullity ty)) where + => Num (Expression schema relations grouping params (nullity ty)) where (+) = unsafeBinaryOp "+" (-) = unsafeBinaryOp "-" (*) = unsafeBinaryOp "*" @@ -463,12 +473,12 @@ instance PGNum ty . show instance (PGNum ty, PGFloating ty) => Fractional - (Expression relations grouping params (nullity ty)) where + (Expression schema relations grouping params (nullity ty)) where (/) = unsafeBinaryOp "/" fromRational x = fromInteger (numerator x) / fromInteger (denominator x) instance (PGNum ty, PGFloating ty) => Floating - (Expression relations grouping params (nullity ty)) where + (Expression schema relations grouping params (nullity ty)) where pi = UnsafeExpression "pi()" exp = unsafeFunction "exp" log = unsafeFunction "ln" @@ -491,18 +501,18 @@ instance (PGNum ty, PGFloating ty) => Floating -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = atan2_ pi 2 -- in renderExpression expression -- :} -- "atan2(pi(), 2)" atan2_ :: PGFloating float - => Expression relations grouping params (nullity float) + => Expression schema relations grouping params (nullity float) -- ^ numerator - -> Expression relations grouping params (nullity float) + -> Expression schema relations grouping params (nullity float) -- ^ denominator - -> Expression relations grouping params (nullity float) + -> Expression schema relations grouping params (nullity float) atan2_ y x = UnsafeExpression $ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")" @@ -513,11 +523,11 @@ atan2_ y x = UnsafeExpression $ -- | >>> renderExpression $ true & cast int4 -- "(TRUE :: int4)" cast - :: TypeExpression ty1 + :: TypeExpression schema ty1 -- ^ type to cast as - -> Expression relations grouping params (nullity ty0) + -> Expression schema relations grouping params (nullity ty0) -- ^ value to convert - -> Expression relations grouping params (nullity ty1) + -> Expression schema relations grouping params (nullity ty1) cast ty x = UnsafeExpression $ parenthesized $ renderExpression x <+> "::" <+> renderTypeExpression ty @@ -525,135 +535,135 @@ cast ty x = UnsafeExpression $ parenthesized $ -- -- >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = 5 `quot_` 2 -- in renderExpression expression -- :} -- "(5 / 2)" quot_ :: PGIntegral int - => Expression relations grouping params (nullity int) + => Expression schema relations grouping params (nullity int) -- ^ numerator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) -- ^ denominator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) quot_ = unsafeBinaryOp "/" -- | remainder upon integer division -- -- >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = 5 `rem_` 2 -- in renderExpression expression -- :} -- "(5 % 2)" rem_ :: PGIntegral int - => Expression relations grouping params (nullity int) + => Expression schema relations grouping params (nullity int) -- ^ numerator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) -- ^ denominator - -> Expression relations grouping params (nullity int) + -> Expression schema relations grouping params (nullity int) rem_ = unsafeBinaryOp "%" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = trunc pi -- in renderExpression expression -- :} -- "trunc(pi())" trunc :: PGFloating frac - => Expression relations grouping params (nullity frac) + => Expression schema relations grouping params (nullity frac) -- ^ fractional number - -> Expression relations grouping params (nullity frac) + -> Expression schema relations grouping params (nullity frac) trunc = unsafeFunction "trunc" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = round_ pi -- in renderExpression expression -- :} -- "round(pi())" round_ :: PGFloating frac - => Expression relations grouping params (nullity frac) + => Expression schema relations grouping params (nullity frac) -- ^ fractional number - -> Expression relations grouping params (nullity frac) + -> Expression schema relations grouping params (nullity frac) round_ = unsafeFunction "round" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGfloat4) +-- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = ceiling_ pi -- in renderExpression expression -- :} -- "ceiling(pi())" ceiling_ :: PGFloating frac - => Expression relations grouping params (nullity frac) + => Expression schema relations grouping params (nullity frac) -- ^ fractional number - -> Expression relations grouping params (nullity frac) + -> Expression schema relations grouping params (nullity frac) ceiling_ = unsafeFunction "ceiling" -- | A `Condition` is a boolean valued `Expression`. While SQL allows -- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@, -- forcing one to handle the case of @NULL@ explicitly to produce -- a `Condition`. -type Condition relations grouping params = - Expression relations grouping params ('NotNull 'PGbool) +type Condition schema relations grouping params = + Expression schema relations grouping params ('NotNull 'PGbool) -- | >>> renderExpression true -- "TRUE" -true :: Condition relations grouping params +true :: Condition schema relations grouping params true = UnsafeExpression "TRUE" -- | >>> renderExpression false -- "FALSE" -false :: Condition relations grouping params +false :: Condition schema relations grouping params false = UnsafeExpression "FALSE" -- | >>> renderExpression $ not_ true -- "(NOT TRUE)" not_ - :: Condition relations grouping params - -> Condition relations grouping params + :: Condition schema relations grouping params + -> Condition schema relations grouping params not_ = unsafeUnaryOp "NOT" -- | >>> renderExpression $ true .&& false -- "(TRUE AND FALSE)" (.&&) - :: Condition relations grouping params - -> Condition relations grouping params - -> Condition relations grouping params + :: Condition schema relations grouping params + -> Condition schema relations grouping params + -> Condition schema relations grouping params (.&&) = unsafeBinaryOp "AND" -- | >>> renderExpression $ true .|| false -- "(TRUE OR FALSE)" (.||) - :: Condition relations grouping params - -> Condition relations grouping params - -> Condition relations grouping params + :: Condition schema relations grouping params + -> Condition schema relations grouping params + -> Condition schema relations grouping params (.||) = unsafeBinaryOp "OR" -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 -- in renderExpression expression -- :} -- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END" caseWhenThenElse - :: [ ( Condition relations grouping params - , Expression relations grouping params (ty) + :: [ ( Condition schema relations grouping params + , Expression schema relations grouping params (ty) ) ] -- ^ whens and thens - -> Expression relations grouping params (ty) + -> Expression schema relations grouping params (ty) -- ^ else - -> Expression relations grouping params (ty) + -> Expression schema relations grouping params (ty) caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat [ "CASE" , mconcat @@ -669,16 +679,16 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat -- | >>> :{ -- let --- expression :: Expression relations grouping params (nullity 'PGint2) +-- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = ifThenElse true 1 0 -- in renderExpression expression -- :} -- "CASE WHEN TRUE THEN 1 ELSE 0 END" ifThenElse - :: Condition relations grouping params - -> Expression relations grouping params (ty) -- ^ then - -> Expression relations grouping params (ty) -- ^ else - -> Expression relations grouping params (ty) + :: Condition schema relations grouping params + -> Expression schema relations grouping params (ty) -- ^ then + -> Expression schema relations grouping params (ty) -- ^ else + -> Expression schema relations grouping params (ty) ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=` @@ -687,85 +697,85 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ -- >>> renderExpression $ notNull true .== null_ -- "(TRUE = NULL)" (.==) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.==) = unsafeBinaryOp "=" infix 4 .== -- | >>> renderExpression $ notNull true ./= null_ -- "(TRUE <> NULL)" (./=) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (./=) = unsafeBinaryOp "<>" infix 4 ./= -- | >>> renderExpression $ notNull true .>= null_ -- "(TRUE >= NULL)" (.>=) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.>=) = unsafeBinaryOp ">=" infix 4 .>= -- | >>> renderExpression $ notNull true .< null_ -- "(TRUE < NULL)" (.<) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.<) = unsafeBinaryOp "<" infix 4 .< -- | >>> renderExpression $ notNull true .<= null_ -- "(TRUE <= NULL)" (.<=) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.<=) = unsafeBinaryOp "<=" infix 4 .<= -- | >>> renderExpression $ notNull true .> null_ -- "(TRUE > NULL)" (.>) - :: Expression relations grouping params (nullity ty) -- ^ lhs - -> Expression relations grouping params (nullity ty) -- ^ rhs - -> Expression relations grouping params (nullity 'PGbool) + :: Expression schema relations grouping params (nullity ty) -- ^ lhs + -> Expression schema relations grouping params (nullity ty) -- ^ rhs + -> Expression schema relations grouping params (nullity 'PGbool) (.>) = unsafeBinaryOp ">" infix 4 .> -- | >>> renderExpression currentDate -- "CURRENT_DATE" currentDate - :: Expression relations grouping params (nullity 'PGdate) + :: Expression schema relations grouping params (nullity 'PGdate) currentDate = UnsafeExpression "CURRENT_DATE" -- | >>> renderExpression currentTime -- "CURRENT_TIME" currentTime - :: Expression relations grouping params (nullity 'PGtimetz) + :: Expression schema relations grouping params (nullity 'PGtimetz) currentTime = UnsafeExpression "CURRENT_TIME" -- | >>> renderExpression currentTimestamp -- "CURRENT_TIMESTAMP" currentTimestamp - :: Expression relations grouping params (nullity 'PGtimestamptz) + :: Expression schema relations grouping params (nullity 'PGtimestamptz) currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP" -- | >>> renderExpression localTime -- "LOCALTIME" localTime - :: Expression relations grouping params (nullity 'PGtime) + :: Expression schema relations grouping params (nullity 'PGtime) localTime = UnsafeExpression "LOCALTIME" -- | >>> renderExpression localTimestamp -- "LOCALTIMESTAMP" localTimestamp - :: Expression relations grouping params (nullity 'PGtimestamp) + :: Expression schema relations grouping params (nullity 'PGtimestamp) localTimestamp = UnsafeExpression "LOCALTIMESTAMP" {----------------------------------------- @@ -773,7 +783,7 @@ text -----------------------------------------} instance IsString - (Expression relations grouping params (nullity 'PGtext)) where + (Expression schema relations grouping params (nullity 'PGtext)) where fromString str = UnsafeExpression $ "E\'" <> fromString (escape =<< str) <> "\'" where @@ -789,36 +799,36 @@ instance IsString c -> [c] instance Semigroup - (Expression relations grouping params (nullity 'PGtext)) where + (Expression schema relations grouping params (nullity 'PGtext)) where (<>) = unsafeBinaryOp "||" instance Monoid - (Expression relations grouping params (nullity 'PGtext)) where + (Expression schema relations grouping params (nullity 'PGtext)) where mempty = fromString "" mappend = (<>) -- | >>> renderExpression $ lower "ARRRGGG" -- "lower(E'ARRRGGG')" lower - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to lower case - -> Expression relations grouping params (nullity 'PGtext) + -> Expression schema relations grouping params (nullity 'PGtext) lower = unsafeFunction "lower" -- | >>> renderExpression $ upper "eeee" -- "upper(E'eeee')" upper - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to upper case - -> Expression relations grouping params (nullity 'PGtext) + -> Expression schema relations grouping params (nullity 'PGtext) upper = unsafeFunction "upper" -- | >>> renderExpression $ charLength "four" -- "char_length(E'four')" charLength - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to measure - -> Expression relations grouping params (nullity 'PGint4) + -> Expression schema relations grouping params (nullity 'PGint4) charLength = unsafeFunction "char_length" -- | The `like` expression returns true if the @string@ matches @@ -831,11 +841,11 @@ charLength = unsafeFunction "char_length" -- >>> renderExpression $ "abc" `like` "a%" -- "(E'abc' LIKE E'a%')" like - :: Expression relations grouping params (nullity 'PGtext) + :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string - -> Expression relations grouping params (nullity 'PGtext) + -> Expression schema relations grouping params (nullity 'PGtext) -- ^ pattern - -> Expression relations grouping params (nullity 'PGbool) + -> Expression schema relations grouping params (nullity 'PGbool) like = unsafeBinaryOp "LIKE" {----------------------------------------- @@ -845,16 +855,16 @@ aggregation -- | escape hatch to define aggregate functions unsafeAggregate :: ByteString -- ^ aggregate function - -> Expression relations 'Ungrouped params (xty) - -> Expression relations ('Grouped bys) params (yty) + -> Expression schema relations 'Ungrouped params (xty) + -> Expression schema relations ('Grouped bys) params (yty) unsafeAggregate fun x = UnsafeExpression $ mconcat [fun, "(", renderExpression x, ")"] -- | escape hatch to define aggregate functions over distinct values unsafeAggregateDistinct :: ByteString -- ^ aggregate function - -> Expression relations 'Ungrouped params (xty) - -> Expression relations ('Grouped bys) params (yty) + -> Expression schema relations 'Ungrouped params (xty) + -> Expression schema relations ('Grouped bys) params (yty) unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat [fun, "(DISTINCT ", renderExpression x, ")"] @@ -867,9 +877,9 @@ unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat -- "sum(\"col\")" sum_ :: PGNum ty - => Expression relations 'Ungrouped params (nullity ty) + => Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to sum - -> Expression relations ('Grouped bys) params (nullity ty) + -> Expression schema relations ('Grouped bys) params (nullity ty) sum_ = unsafeAggregate "sum" -- | >>> :{ @@ -881,18 +891,18 @@ sum_ = unsafeAggregate "sum" -- "sum(DISTINCT \"col\")" sumDistinct :: PGNum ty - => Expression relations 'Ungrouped params (nullity ty) + => Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to sum - -> Expression relations ('Grouped bys) params (nullity ty) + -> Expression schema relations ('Grouped bys) params (nullity ty) sumDistinct = unsafeAggregateDistinct "sum" -- | A constraint for `PGType`s that you can take averages of and the resulting -- `PGType`. class PGAvg ty avg | ty -> avg where avg, avgDistinct - :: Expression relations 'Ungrouped params (nullity ty) + :: Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to average - -> Expression relations ('Grouped bys) params (nullity avg) + -> Expression schema relations ('Grouped bys) params (nullity avg) avg = unsafeAggregate "avg" avgDistinct = unsafeAggregateDistinct "avg" instance PGAvg 'PGint2 'PGnumeric @@ -912,9 +922,9 @@ instance PGAvg 'PGinterval 'PGinterval -- "bit_and(\"col\")" bitAnd :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitAnd = unsafeAggregate "bit_and" -- | >>> :{ @@ -926,9 +936,9 @@ bitAnd = unsafeAggregate "bit_and" -- "bit_or(\"col\")" bitOr :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitOr = unsafeAggregate "bit_or" -- | >>> :{ @@ -940,9 +950,9 @@ bitOr = unsafeAggregate "bit_or" -- "bit_and(DISTINCT \"col\")" bitAndDistinct :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitAndDistinct = unsafeAggregateDistinct "bit_and" -- | >>> :{ @@ -954,9 +964,9 @@ bitAndDistinct = unsafeAggregateDistinct "bit_and" -- "bit_or(DISTINCT \"col\")" bitOrDistinct :: PGIntegral int - => Expression relations 'Ungrouped params (nullity int) + => Expression schema relations 'Ungrouped params (nullity int) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity int) + -> Expression schema relations ('Grouped bys) params (nullity int) bitOrDistinct = unsafeAggregateDistinct "bit_or" -- | >>> :{ @@ -967,9 +977,9 @@ bitOrDistinct = unsafeAggregateDistinct "bit_or" -- :} -- "bool_and(\"col\")" boolAnd - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolAnd = unsafeAggregate "bool_and" -- | >>> :{ @@ -980,9 +990,9 @@ boolAnd = unsafeAggregate "bool_and" -- :} -- "bool_or(\"col\")" boolOr - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolOr = unsafeAggregate "bool_or" -- | >>> :{ @@ -993,9 +1003,9 @@ boolOr = unsafeAggregate "bool_or" -- :} -- "bool_and(DISTINCT \"col\")" boolAndDistinct - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolAndDistinct = unsafeAggregateDistinct "bool_and" -- | >>> :{ @@ -1006,9 +1016,9 @@ boolAndDistinct = unsafeAggregateDistinct "bool_and" -- :} -- "bool_or(DISTINCT \"col\")" boolOrDistinct - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) boolOrDistinct = unsafeAggregateDistinct "bool_or" -- | A special aggregation that does not require an input @@ -1016,7 +1026,7 @@ boolOrDistinct = unsafeAggregateDistinct "bool_or" -- >>> renderExpression countStar -- "count(*)" countStar - :: Expression relations ('Grouped bys) params ('NotNull 'PGint8) + :: Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) countStar = UnsafeExpression $ "count(*)" -- | >>> :{ @@ -1027,9 +1037,9 @@ countStar = UnsafeExpression $ "count(*)" -- :} -- "count(\"col\")" count - :: Expression relations 'Ungrouped params ty + :: Expression schema relations 'Ungrouped params ty -- ^ what to count - -> Expression relations ('Grouped bys) params ('NotNull 'PGint8) + -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) count = unsafeAggregate "count" -- | >>> :{ @@ -1040,9 +1050,9 @@ count = unsafeAggregate "count" -- :} -- "count(DISTINCT \"col\")" countDistinct - :: Expression relations 'Ungrouped params ty + :: Expression schema relations 'Ungrouped params ty -- ^ what to count - -> Expression relations ('Grouped bys) params ('NotNull 'PGint8) + -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) countDistinct = unsafeAggregateDistinct "count" -- | synonym for `boolAnd` @@ -1055,9 +1065,9 @@ countDistinct = unsafeAggregateDistinct "count" -- :} -- "every(\"col\")" every - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) every = unsafeAggregate "every" -- | synonym for `boolAndDistinct` @@ -1070,16 +1080,16 @@ every = unsafeAggregate "every" -- :} -- "every(DISTINCT \"col\")" everyDistinct - :: Expression relations 'Ungrouped params (nullity 'PGbool) + :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity 'PGbool) + -> Expression schema relations ('Grouped bys) params (nullity 'PGbool) everyDistinct = unsafeAggregateDistinct "every" -- | minimum and maximum aggregation max_, min_, maxDistinct, minDistinct - :: Expression relations 'Ungrouped params (nullity ty) + :: Expression schema relations 'Ungrouped params (nullity ty) -- ^ what to aggregate - -> Expression relations ('Grouped bys) params (nullity ty) + -> Expression schema relations ('Grouped bys) params (nullity ty) max_ = unsafeAggregate "max" min_ = unsafeAggregate "min" maxDistinct = unsafeAggregateDistinct "max" @@ -1090,92 +1100,96 @@ type expressions -----------------------------------------} -- | `TypeExpression`s are used in `cast`s and `createTable` commands. -newtype TypeExpression (ty :: PGType) +newtype TypeExpression (schema :: SchemaType) (ty :: PGType) = UnsafeTypeExpression { renderTypeExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance (Has alias schema ('Typedef ty)) + => IsLabel alias (TypeExpression schema ty) where + fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias)) + -- | logical Boolean (true/false) -bool :: TypeExpression 'PGbool +bool :: TypeExpression schema 'PGbool bool = UnsafeTypeExpression "bool" -- | signed two-byte integer -int2, smallint :: TypeExpression 'PGint2 +int2, smallint :: TypeExpression schema 'PGint2 int2 = UnsafeTypeExpression "int2" smallint = UnsafeTypeExpression "smallint" -- | signed four-byte integer -int4, int, integer :: TypeExpression 'PGint4 +int4, int, integer :: TypeExpression schema 'PGint4 int4 = UnsafeTypeExpression "int4" int = UnsafeTypeExpression "int" integer = UnsafeTypeExpression "integer" -- | signed eight-byte integer -int8, bigint :: TypeExpression 'PGint8 +int8, bigint :: TypeExpression schema 'PGint8 int8 = UnsafeTypeExpression "int8" bigint = UnsafeTypeExpression "bigint" -- | arbitrary precision numeric type -numeric :: TypeExpression 'PGnumeric +numeric :: TypeExpression schema 'PGnumeric numeric = UnsafeTypeExpression "numeric" -- | single precision floating-point number (4 bytes) -float4, real :: TypeExpression 'PGfloat4 +float4, real :: TypeExpression schema 'PGfloat4 float4 = UnsafeTypeExpression "float4" real = UnsafeTypeExpression "real" -- | double precision floating-point number (8 bytes) -float8, doublePrecision :: TypeExpression 'PGfloat8 +float8, doublePrecision :: TypeExpression schema 'PGfloat8 float8 = UnsafeTypeExpression "float8" doublePrecision = UnsafeTypeExpression "double precision" -- | variable-length character string -text :: TypeExpression 'PGtext +text :: TypeExpression schema 'PGtext text = UnsafeTypeExpression "text" -- | fixed-length character string char, character :: (KnownNat n, 1 <= n) => proxy n - -> TypeExpression ('PGchar n) + -> TypeExpression schema ('PGchar n) char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")" character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")" -- | variable-length character string varchar, characterVarying :: (KnownNat n, 1 <= n) => proxy n - -> TypeExpression ('PGvarchar n) + -> TypeExpression schema ('PGvarchar n) varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")" characterVarying p = UnsafeTypeExpression $ "character varying(" <> renderNat p <> ")" -- | binary data ("byte array") -bytea :: TypeExpression 'PGbytea +bytea :: TypeExpression schema 'PGbytea bytea = UnsafeTypeExpression "bytea" -- | date and time (no time zone) -timestamp :: TypeExpression 'PGtimestamp +timestamp :: TypeExpression schema 'PGtimestamp timestamp = UnsafeTypeExpression "timestamp" -- | date and time, including time zone -timestampWithTimeZone :: TypeExpression 'PGtimestamptz +timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone" -- | calendar date (year, month, day) -date :: TypeExpression 'PGdate +date :: TypeExpression schema 'PGdate date = UnsafeTypeExpression "date" -- | time of day (no time zone) -time :: TypeExpression 'PGtime +time :: TypeExpression schema 'PGtime time = UnsafeTypeExpression "time" -- | time of day, including time zone -timeWithTimeZone :: TypeExpression 'PGtimetz +timeWithTimeZone :: TypeExpression schema 'PGtimetz timeWithTimeZone = UnsafeTypeExpression "time with time zone" -- | time span -interval :: TypeExpression 'PGinterval +interval :: TypeExpression schema 'PGinterval interval = UnsafeTypeExpression "interval" -- | universally unique identifier -uuid :: TypeExpression 'PGuuid +uuid :: TypeExpression schema 'PGuuid uuid = UnsafeTypeExpression "uuid" -- | IPv4 or IPv6 host address -inet :: TypeExpression 'PGinet +inet :: TypeExpression schema 'PGinet inet = UnsafeTypeExpression "inet" -- | textual JSON data -json :: TypeExpression 'PGjson +json :: TypeExpression schema 'PGjson json = UnsafeTypeExpression "json" -- | binary JSON data, decomposed -jsonb :: TypeExpression 'PGjsonb +jsonb :: TypeExpression schema 'PGjsonb jsonb = UnsafeTypeExpression "jsonb" -- | variable length array vararray - :: TypeExpression pg - -> TypeExpression ('PGvararray pg) + :: TypeExpression schema pg + -> TypeExpression schema ('PGvararray pg) vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]" -- | fixed length array -- @@ -1184,36 +1198,36 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]" fixarray :: KnownNat n => proxy n - -> TypeExpression pg - -> TypeExpression ('PGfixarray n pg) + -> TypeExpression schema pg + -> TypeExpression schema ('PGfixarray n pg) fixarray p ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[" <> renderNat p <> "]" -- | `pgtype` is a demoted version of a `PGType` -class PGTyped (ty :: PGType) where pgtype :: TypeExpression ty -instance PGTyped 'PGbool where pgtype = bool -instance PGTyped 'PGint2 where pgtype = int2 -instance PGTyped 'PGint4 where pgtype = int4 -instance PGTyped 'PGint8 where pgtype = int8 -instance PGTyped 'PGnumeric where pgtype = numeric -instance PGTyped 'PGfloat4 where pgtype = float4 -instance PGTyped 'PGfloat8 where pgtype = float8 -instance PGTyped 'PGtext where pgtype = text +class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty +instance PGTyped schema 'PGbool where pgtype = bool +instance PGTyped schema 'PGint2 where pgtype = int2 +instance PGTyped schema 'PGint4 where pgtype = int4 +instance PGTyped schema 'PGint8 where pgtype = int8 +instance PGTyped schema 'PGnumeric where pgtype = numeric +instance PGTyped schema 'PGfloat4 where pgtype = float4 +instance PGTyped schema 'PGfloat8 where pgtype = float8 +instance PGTyped schema 'PGtext where pgtype = text instance (KnownNat n, 1 <= n) - => PGTyped ('PGchar n) where pgtype = char (Proxy @n) + => PGTyped schema ('PGchar n) where pgtype = char (Proxy @n) instance (KnownNat n, 1 <= n) - => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n) -instance PGTyped 'PGbytea where pgtype = bytea -instance PGTyped 'PGtimestamp where pgtype = timestamp -instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone -instance PGTyped 'PGdate where pgtype = date -instance PGTyped 'PGtime where pgtype = time -instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone -instance PGTyped 'PGinterval where pgtype = interval -instance PGTyped 'PGuuid where pgtype = uuid -instance PGTyped 'PGjson where pgtype = json -instance PGTyped 'PGjsonb where pgtype = jsonb -instance PGTyped ty => PGTyped ('PGvararray ty) where - pgtype = vararray (pgtype @ty) -instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where - pgtype = fixarray (Proxy @n) (pgtype @ty) + => PGTyped schema ('PGvarchar n) where pgtype = varchar (Proxy @n) +instance PGTyped schema 'PGbytea where pgtype = bytea +instance PGTyped schema 'PGtimestamp where pgtype = timestamp +instance PGTyped schema 'PGtimestamptz where pgtype = timestampWithTimeZone +instance PGTyped schema 'PGdate where pgtype = date +instance PGTyped schema 'PGtime where pgtype = time +instance PGTyped schema 'PGtimetz where pgtype = timeWithTimeZone +instance PGTyped schema 'PGinterval where pgtype = interval +instance PGTyped schema 'PGuuid where pgtype = uuid +instance PGTyped schema 'PGjson where pgtype = json +instance PGTyped schema 'PGjsonb where pgtype = jsonb +instance PGTyped schema ty => PGTyped schema ('PGvararray ty) where + pgtype = vararray (pgtype @schema @ty) +instance (KnownNat n, PGTyped schema ty) => PGTyped schema ('PGfixarray n ty) where + pgtype = fixarray (Proxy @n) (pgtype @schema @ty) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index 1d165f7f..fcc291a0 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -211,11 +211,11 @@ insertRows , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert - -> ConflictClause columns params + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert + -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert + -> ConflictClause schema columns params -- ^ what to do in case of constraint conflict - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results insertRows tab rw rws conflict returning = UnsafeManipulation $ "INSERT" <+> "INTO" <+> renderAlias tab @@ -228,7 +228,7 @@ insertRows tab rw rws conflict returning = UnsafeManipulation $ <> renderReturningClause returning where renderAliasPart, renderColumnValuePart - :: Aliased (ColumnValue '[] params) ty -> ByteString + :: Aliased (ColumnValue schema '[] params) ty -> ByteString renderAliasPart (_ `As` name) = renderAlias name renderColumnValuePart (value `As` _) = case value of Default -> "DEFAULT" @@ -241,10 +241,10 @@ insertRow , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> ConflictClause columns params + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert + -> ConflictClause schema columns params -- ^ what to do in case of constraint conflict - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results insertRow tab rw = insertRows tab rw [] @@ -254,8 +254,8 @@ insertRows_ , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert - -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert + -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert -> Manipulation schema params '[] insertRows_ tab rw rws = insertRows tab rw rws OnConflictDoRaise (Returning Nil) @@ -266,7 +266,7 @@ insertRow_ , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into - -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert + -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert -> Manipulation schema params '[] insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil) @@ -278,9 +278,9 @@ insertQuery , columns ~ TableToColumns table ) => Alias tab -- ^ table to insert into -> Query schema params (ColumnsToRelation columns) - -> ConflictClause columns params + -> ConflictClause schema columns params -- ^ what to do in case of constraint conflict - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results insertQuery tab query conflict returning = UnsafeManipulation $ "INSERT" <+> "INTO" <+> renderAlias tab @@ -305,15 +305,16 @@ insertQuery_ tab query = -- `Set` a value to be an `Expression`, relative to the given -- row for an update, and closed for an insert. data ColumnValue + (schema :: SchemaType) (columns :: RelationType) (params :: [NullityType]) (ty :: ColumnType) where - Same :: ColumnValue (column ': columns) params ty - Default :: ColumnValue columns params ('Def :=> ty) + Same :: ColumnValue schema (column ': columns) params ty + Default :: ColumnValue schema columns params ('Def :=> ty) Set - :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty) - -> ColumnValue columns params (constraint :=> ty) + :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty) + -> ColumnValue schema columns params (constraint :=> ty) -- | A `ReturningClause` computes and return value(s) based -- on each row actually inserted, updated or deleted. This is primarily @@ -326,22 +327,23 @@ data ColumnValue -- in the row. Use @Returning Nil@ in the common case where no return -- values are desired. data ReturningClause + (schema :: SchemaType) (columns :: ColumnsType) (params :: [NullityType]) (results :: RelationType) where ReturningStar :: results ~ ColumnsToRelation columns - => ReturningClause columns params results + => ReturningClause schema columns params results Returning :: rel ~ ColumnsToRelation columns - => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results - -> ReturningClause columns params results + => NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results + -> ReturningClause schema columns params results -- | Render a `ReturningClause`. renderReturningClause :: SOP.SListI results - => ReturningClause params columns results + => ReturningClause schema params columns results -> ByteString renderReturningClause = \case ReturningStar -> " RETURNING *" @@ -354,18 +356,18 @@ renderReturningClause = \case -- `OnConflictDoNothing` simply avoids inserting a row. -- `OnConflictDoUpdate` updates the existing row that conflicts with the row -- proposed for insertion. -data ConflictClause (columns :: ColumnsType) params where - OnConflictDoRaise :: ConflictClause columns params - OnConflictDoNothing :: ConflictClause columns params +data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where + OnConflictDoRaise :: ConflictClause schema columns params + OnConflictDoNothing :: ConflictClause schema columns params OnConflictDoUpdate - :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns - -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params] - -> ConflictClause columns params + :: NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns + -> [Condition schema '[table ::: ColumnsToRelation columns] 'Ungrouped params] + -> ConflictClause schema columns params -- | Render a `ConflictClause`. renderConflictClause :: SOP.SListI columns - => ConflictClause columns params + => ConflictClause schema columns params -> ByteString renderConflictClause = \case OnConflictDoRaise -> "" @@ -378,7 +380,7 @@ renderConflictClause = \case wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs) where renderUpdate - :: Aliased (ColumnValue columns params) column + :: Aliased (ColumnValue schema columns params) column -> Maybe ByteString renderUpdate = \case Same `As` _ -> Nothing @@ -399,11 +401,11 @@ update , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to update - -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns + -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to perform update on a row - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results update tab columns wh returning = UnsafeManipulation $ "UPDATE" @@ -414,7 +416,7 @@ update tab columns wh returning = UnsafeManipulation $ <> renderReturningClause returning where renderUpdate - :: Aliased (ColumnValue columns params) column + :: Aliased (ColumnValue schema columns params) column -> Maybe ByteString renderUpdate = \case Same `As` _ -> Nothing @@ -429,9 +431,9 @@ update_ , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to update - -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns + -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns -- ^ modified values to replace old values - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to perform update on a row -> Manipulation schema params '[] update_ tab columns wh = update tab columns wh (Returning Nil) @@ -446,9 +448,9 @@ deleteFrom , Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to delete a row - -> ReturningClause columns params results -- ^ results to return + -> ReturningClause schema columns params results -- ^ results to return -> Manipulation schema params results deleteFrom tab wh returning = UnsafeManipulation $ "DELETE FROM" <+> renderAlias tab @@ -460,7 +462,7 @@ deleteFrom_ :: ( Has tab schema ('Table table) , columns ~ TableToColumns table ) => Alias tab -- ^ table to delete from - -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params + -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params -- ^ condition under which to delete a row -> Manipulation schema params '[] deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 889b41cd..3b29231f 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -359,7 +359,7 @@ SELECT queries -- the intermediate table are actually output. select :: SListI columns - => NP (Aliased (Expression relations grouping params)) (column ': columns) + => NP (Aliased (Expression schema relations grouping params)) (column ': columns) -- ^ select list -> TableExpression schema params relations grouping -- ^ intermediate virtual table @@ -373,7 +373,7 @@ select list rels = UnsafeQuery $ -- be subject to the elimination of duplicate rows using `selectDistinct`. selectDistinct :: SListI columns - => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns) + => NP (Aliased (Expression schema relations 'Ungrouped params)) (column ': columns) -- ^ select list -> TableExpression schema params relations 'Ungrouped -- ^ intermediate virtual table @@ -438,8 +438,8 @@ selectDistinctDotStar rel relations = UnsafeQuery $ -- "SELECT * FROM (VALUES (1, E'one')) AS t (\"a\", \"b\")" values :: SListI cols - => NP (Aliased (Expression '[] 'Ungrouped params)) cols - -> [NP (Aliased (Expression '[] 'Ungrouped params)) cols] + => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols + -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols] -- ^ When more than one row is specified, all the rows must -- must have the same number of elements -> Query schema params cols @@ -453,7 +453,7 @@ values rw rws = UnsafeQuery $ "SELECT * FROM" <+> parenthesized (renderCommaSeparated renderAliasPart rw) where renderAliasPart, renderValuePart - :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString + :: Aliased (Expression schema '[] 'Ungrouped params) ty -> ByteString renderAliasPart (_ `As` name) = renderAlias name renderValuePart (value `As` _) = renderExpression value @@ -461,7 +461,7 @@ values rw rws = UnsafeQuery $ "SELECT * FROM" -- specified by value expressions. values_ :: SListI cols - => NP (Aliased (Expression '[] 'Ungrouped params)) cols + => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols -- ^ one row of values -> Query schema params cols values_ rw = values rw [] @@ -485,7 +485,7 @@ data TableExpression { fromClause :: FromClause schema params relations -- ^ A table reference that can be a table name, or a derived table such -- as a subquery, a @JOIN@ construct, or complex combinations of these. - , whereClause :: [Condition relations 'Ungrouped params] + , whereClause :: [Condition schema relations 'Ungrouped params] -- ^ optional search coditions, combined with `.&&`. After the processing -- of the `fromClause` is done, each row of the derived virtual table -- is checked against the search condition. If the result of the @@ -501,13 +501,13 @@ data TableExpression -- set of rows having common values into one group row that represents all -- rows in the group. This is done to eliminate redundancy in the output -- and/or compute aggregates that apply to these groups. - , havingClause :: HavingClause relations grouping params + , havingClause :: HavingClause schema relations grouping params -- ^ If a table has been grouped using `groupBy`, but only certain groups -- are of interest, the `havingClause` can be used, much like a -- `whereClause`, to eliminate groups from the result. Expressions in the -- `havingClause` can refer both to grouped expressions and to ungrouped -- expressions (which necessarily involve an aggregate function). - , orderByClause :: [SortExpression relations grouping params] + , orderByClause :: [SortExpression schema relations grouping params] -- ^ The `orderByClause` is for optional sorting. When more than one -- `SortExpression` is specified, the later (right) values are used to sort -- rows that are equal according to the earlier (left) values. @@ -566,7 +566,7 @@ from rels = TableExpression rels [] NoGroups NoHaving [] [] [] -- | A `where_` is an endomorphism of `TableExpression`s which adds a -- search condition to the `whereClause`. where_ - :: Condition relations 'Ungrouped params -- ^ filtering condition + :: Condition schema relations 'Ungrouped params -- ^ filtering condition -> TableExpression schema params relations grouping -> TableExpression schema params relations grouping where_ wh rels = rels {whereClause = wh : whereClause rels} @@ -592,7 +592,7 @@ group bys rels = TableExpression -- | A `having` is an endomorphism of `TableExpression`s which adds a -- search condition to the `havingClause`. having - :: Condition relations ('Grouped bys) params -- ^ having condition + :: Condition schema relations ('Grouped bys) params -- ^ having condition -> TableExpression schema params relations ('Grouped bys) -> TableExpression schema params relations ('Grouped bys) having hv rels = rels @@ -601,7 +601,7 @@ having hv rels = rels -- | An `orderBy` is an endomorphism of `TableExpression`s which appends an -- ordering to the right of the `orderByClause`. orderBy - :: [SortExpression relations grouping params] -- ^ sort expressions + :: [SortExpression schema relations grouping params] -- ^ sort expressions -> TableExpression schema params relations grouping -> TableExpression schema params relations grouping orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts} @@ -677,7 +677,7 @@ the @on@ condition. innerJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -694,7 +694,7 @@ innerJoin right on left = UnsafeFromClause $ leftOuterJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -712,7 +712,7 @@ leftOuterJoin right on left = UnsafeFromClause $ rightOuterJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -731,7 +731,7 @@ rightOuterJoin right on left = UnsafeFromClause $ fullOuterJoin :: FromClause schema params right -- ^ right - -> Condition (Join left right) 'Ungrouped params + -> Condition schema (Join left right) 'Ungrouped params -- ^ @on@ condition -> FromClause schema params left -- ^ left @@ -795,17 +795,17 @@ renderGroupByClause = \case -- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped` -- `TableExpression` must use `Having` whose conditions are combined with -- `.&&`. -data HavingClause relations grouping params where - NoHaving :: HavingClause relations 'Ungrouped params +data HavingClause schema relations grouping params where + NoHaving :: HavingClause schema relations 'Ungrouped params Having - :: [Condition relations ('Grouped bys) params] - -> HavingClause relations ('Grouped bys) params -deriving instance Show (HavingClause relations grouping params) -deriving instance Eq (HavingClause relations grouping params) -deriving instance Ord (HavingClause relations grouping params) + :: [Condition schema relations ('Grouped bys) params] + -> HavingClause schema relations ('Grouped bys) params +deriving instance Show (HavingClause schema relations grouping params) +deriving instance Eq (HavingClause schema relations grouping params) +deriving instance Ord (HavingClause schema relations grouping params) -- | Render a `HavingClause`. -renderHavingClause :: HavingClause relations grouping params -> ByteString +renderHavingClause :: HavingClause schema relations grouping params -> ByteString renderHavingClause = \case NoHaving -> "" Having [] -> "" @@ -824,29 +824,29 @@ Sorting -- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to -- determine whether nulls appear before or after non-null values in the sort -- ordering of a `Null` result column. -data SortExpression relations grouping params where +data SortExpression schema relations grouping params where Asc - :: Expression relations grouping params ('NotNull ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('NotNull ty) + -> SortExpression schema relations grouping params Desc - :: Expression relations grouping params ('NotNull ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('NotNull ty) + -> SortExpression schema relations grouping params AscNullsFirst - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params AscNullsLast - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params DescNullsFirst - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params DescNullsLast - :: Expression relations grouping params ('Null ty) - -> SortExpression relations grouping params -deriving instance Show (SortExpression relations grouping params) + :: Expression schema relations grouping params ('Null ty) + -> SortExpression schema relations grouping params +deriving instance Show (SortExpression schema relations grouping params) -- | Render a `SortExpression`. -renderSortExpression :: SortExpression relations grouping params -> ByteString +renderSortExpression :: SortExpression schema relations grouping params -> ByteString renderSortExpression = \case Asc expression -> renderExpression expression <+> "ASC" Desc expression -> renderExpression expression <+> "DESC" From 6e3d875962a55f8438311a04cb5cbcc2860d0415 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 15:41:44 -0700 Subject: [PATCH 52/92] fixes and tests --- .../src/Squeal/PostgreSQL/Binary.hs | 64 +++++++++++-------- .../src/Squeal/PostgreSQL/Definition.hs | 16 +++-- .../src/Squeal/PostgreSQL/Expression.hs | 36 +++++------ 3 files changed, 66 insertions(+), 50 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 4b29781d..968be60b 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -7,10 +7,15 @@ Stability: experimental Binary encoding and decoding between Haskell and PostgreSQL types. -Instances are governed by the `Generic` and `HasDatatype` typeclasses. +Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses. + +Let's see an example of a round trip, inserting a row containing an value of enumerated type +and a value of composite type by encoding Haskell values into Postgres binary format +and then decoding them back into Haskell. >>> import Control.Monad >>> import Control.Monad.Base +>>> import Data.Text >>> import Squeal.PostgreSQL >>> import qualified Squeal.PostgreSQL as SQL @@ -19,46 +24,52 @@ Instances are governed by the `Generic` and `HasDatatype` typeclasses. >>> instance Generic Schwarma >>> instance HasDatatypeInfo Schwarma ->>> let q = values_ (label @"Beef" `As` #fromOnly :* Nil) :: Query '[] '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] - ->>> :{ -void . withConnection "host=localhost port=5432 dbname=exampledb" $ do - result <- runQuery q - Just (Only schwarma) <- firstRow result - liftBase $ print (schwarma :: Schwarma) -:} -Beef +>>> data Person = Person {name :: Maybe Text, age :: Maybe Int32} deriving (Show, GHC.Generic) +>>> instance Generic Person +>>> instance HasDatatypeInfo Person >>> :set -XTypeFamilies -XTypeInType -XUndecidableInstances >>> :{ type family Schema :: SchemaType where Schema = '[ "schwarma" ::: 'Typedef (EnumWith Schwarma) - , "tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull (EnumWith Schwarma)]) + , "person" ::: 'Typedef (CompositeWith Person) + , "tab" ::: 'Table ('[] :=> + '[ "col1" ::: 'NoDef :=> 'NotNull (EnumWith Schwarma) + , "col2" ::: 'NoDef :=> 'NotNull (CompositeWith Person) + ]) ] :} >>> :{ let + setup :: Definition '[] Schema setup = createTypeEnumWith @Schwarma #schwarma >>> - createTable #tab (#schwarma `As` #col :* Nil) Nil - :: Definition '[] Schema - teardown = - dropTable #tab >>> - dropType #schwarma - :: Definition Schema '[] + createTypeCompositeWith @Person #person >>> + createTable #tab ( + notNullable #schwarma `As` #col1 :* + notNullable #person `As` #col2 :* Nil + ) Nil + teardown :: Definition Schema '[] + teardown = dropTable #tab >>> dropType #schwarma >>> dropType #person + manip :: Manipulation Schema '[ 'NotNull (EnumWith Schwarma), 'NotNull (CompositeWith Person)] '[] manip = - insertRow_ #tab (Set (param @1) `As` #col :* Nil) - :: Manipulation Schema '[ 'NotNull (EnumWith Schwarma)] '[] - qry = - select (#col `As` #fromOnly :* Nil) (SQL.from (table #tab)) - :: Query Schema '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] + insertRow_ #tab ( + Set (parameter @1 #schwarma) `As` #col1 :* + Set (parameter @2 #person) `As` #col2 :* Nil) + qry1 :: Query Schema '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] + qry1 = select (#col1 `As` #fromOnly :* Nil) (SQL.from (table #tab)) + qry2 :: Query Schema '[] '["fromOnly" ::: 'NotNull (CompositeWith Person)] + qry2 = select (#col2 `As` #fromOnly :* Nil) (SQL.from (table #tab)) session = do - manipulateParams manip (Only Chicken) - result <- runQuery qry - Just (Only schwarma) <- firstRow result - liftBase $ print (schwarma :: Schwarma) + manipulateParams manip (Chicken, Person (Just "Faisal") (Just 24)) + result1 <- runQuery qry1 + Just (Only schwarma) <- firstRow result1 + liftBase $ print (schwarma :: Schwarma) + result2 <- runQuery qry2 + Just (Only person) <- firstRow result2 + liftBase $ print (person :: Person) :} >>> :{ @@ -68,6 +79,7 @@ void . withConnection "host=localhost port=5432 dbname=exampledb" $ & pqThen (define teardown) :} Chicken +Person {name = Just "Faisal", age = Just 24} -} {-# LANGUAGE diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 427c27bd..67860252 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -807,7 +807,7 @@ dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" -- | Enumerated types are created using the `createTypeEnum` command, for example -- -- >>> renderDefinition $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) --- "CREATE TYPE \"mood\" AS ('sad', 'ok', 'happy');" +-- "CREATE TYPE \"mood\" AS ENUM ('sad', 'ok', 'happy');" createTypeEnum :: (KnownSymbol enum, SOP.All KnownSymbol labels) => Alias enum @@ -816,7 +816,7 @@ createTypeEnum -- ^ labels of the enumerated type -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema) createTypeEnum enum labels = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> + "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+> parenthesized (commaSeparated (renderLabels labels)) <> ";" -- | Enumerated types can also be generated from a Haskell type, for example @@ -825,7 +825,7 @@ createTypeEnum enum labels = UnsafeDefinition $ -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma -- >>> renderDefinition $ createTypeEnumWith @Schwarma #schwarma --- "CREATE TYPE \"schwarma\" AS ('Beef', 'Lamb', 'Chicken');" +-- "CREATE TYPE \"schwarma\" AS ENUM ('Beef', 'Lamb', 'Chicken');" createTypeEnumWith :: forall hask enum schema. ( SOP.Generic hask @@ -842,7 +842,7 @@ createTypeEnumWith enum = createTypeEnum enum -- specified by a list of attribute names and data types. -- -- >>> renderDefinition $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) --- "CREATE TYPE \"complex\" AS (float8 AS \"real\", float8 AS \"imaginary\");" +-- "CREATE TYPE \"complex\" AS (\"real\" float8, \"imaginary\" float8);" createTypeComposite :: (KnownSymbol ty, SOP.SListI fields) => Alias ty @@ -852,7 +852,11 @@ createTypeComposite -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema) createTypeComposite ty fields = UnsafeDefinition $ "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized - (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";" + (renderCommaSeparated renderField fields) <> ";" + where + renderField :: Aliased (TypeExpression schema) x -> ByteString + renderField (typ `As` field) = + renderAlias field <+> renderTypeExpression typ -- | Composite types can also be generated from a Haskell type, for example -- @@ -860,7 +864,7 @@ createTypeComposite ty fields = UnsafeDefinition $ -- >>> instance SOP.Generic Complex -- >>> instance SOP.HasDatatypeInfo Complex -- >>> renderDefinition $ createTypeCompositeWith @Complex #complex --- "CREATE TYPE \"complex\" AS (float8 AS \"real\", float8 AS \"imaginary\");" +-- "CREATE TYPE \"complex\" AS (\"real\" float8, \"imaginary\" float8);" createTypeCompositeWith :: forall hask ty schema. ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index b13afadf..dd44e9e7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -352,7 +352,7 @@ matchNull y f x = ifThenElse (isNull x) y -- `nullIf` gives @NULL@. -- -- >>> :set -XTypeApplications -XDataKinds --- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1)) +-- >>> renderExpression @'[] @_ @_ @'[_] $ fromNull false (nullIf false (param @1)) -- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)" nullIf :: Expression schema relations grouping params ('NotNull ty) @@ -380,7 +380,7 @@ instance (KnownSymbol label, label `In` labels) => IsPGlabel label -- (also called a composite value) using values for its member fields. -- -- >>> type Complex = PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8] --- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] 'Ungrouped '[] ('NotNull Complex) +-- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex) -- >>> renderExpression i -- "ROW(0, 1)" row @@ -407,7 +407,7 @@ instance Monoid mempty = array [] mappend = (<>) --- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1] +-- | >>> renderExpression @'[] @_ @_ @'[_] $ greatest currentTimestamp [param @1] -- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))" greatest :: Expression schema relations grouping params (nullty) @@ -870,7 +870,7 @@ unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric) +-- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric) -- expression = sum_ #col -- in renderExpression expression -- :} @@ -884,7 +884,7 @@ sum_ = unsafeAggregate "sum" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric) -- expression = sumDistinct #col -- in renderExpression expression -- :} @@ -915,7 +915,7 @@ instance PGAvg 'PGinterval 'PGinterval -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitAnd #col -- in renderExpression expression -- :} @@ -929,7 +929,7 @@ bitAnd = unsafeAggregate "bit_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitOr #col -- in renderExpression expression -- :} @@ -943,7 +943,7 @@ bitOr = unsafeAggregate "bit_or" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitAndDistinct #col -- in renderExpression expression -- :} @@ -957,7 +957,7 @@ bitAndDistinct = unsafeAggregateDistinct "bit_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitOrDistinct #col -- in renderExpression expression -- :} @@ -971,7 +971,7 @@ bitOrDistinct = unsafeAggregateDistinct "bit_or" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolAnd #col -- in renderExpression expression -- :} @@ -984,7 +984,7 @@ boolAnd = unsafeAggregate "bool_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolOr #col -- in renderExpression expression -- :} @@ -997,7 +997,7 @@ boolOr = unsafeAggregate "bool_or" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolAndDistinct #col -- in renderExpression expression -- :} @@ -1010,7 +1010,7 @@ boolAndDistinct = unsafeAggregateDistinct "bool_and" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolOrDistinct #col -- in renderExpression expression -- :} @@ -1031,7 +1031,7 @@ countStar = UnsafeExpression $ "count(*)" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) -- expression = count #col -- in renderExpression expression -- :} @@ -1044,7 +1044,7 @@ count = unsafeAggregate "count" -- | >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) -- expression = countDistinct #col -- in renderExpression expression -- :} @@ -1059,7 +1059,7 @@ countDistinct = unsafeAggregateDistinct "count" -- -- >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = every #col -- in renderExpression expression -- :} @@ -1074,7 +1074,7 @@ every = unsafeAggregate "every" -- -- >>> :{ -- let --- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) +-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = everyDistinct #col -- in renderExpression expression -- :} @@ -1204,7 +1204,7 @@ fixarray p ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[" <> renderNat p <> "]" -- | `pgtype` is a demoted version of a `PGType` -class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty +class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty instance PGTyped schema 'PGbool where pgtype = bool instance PGTyped schema 'PGint2 where pgtype = int2 instance PGTyped schema 'PGint4 where pgtype = int4 From 1e229aca9716918bf564b92ab7dc4bf2572e5443 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 16:14:10 -0700 Subject: [PATCH 53/92] docs changes and newline between definitions --- squeal-postgresql/src/Squeal/PostgreSQL.hs | 408 ++++++++--------- .../src/Squeal/PostgreSQL/Definition.hs | 410 +++++++++--------- 2 files changed, 414 insertions(+), 404 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 4ce5fbcc..0fd83a3d 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -1,206 +1,210 @@ --- | Module: Squeal.PostgreSQL --- Description: Squeel export module --- Copyright: (c) Eitan Chatav, 2017 --- Maintainer: eitan@morphism.tech --- Stability: experimental --- --- Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell. --- Let's see an example! --- --- First, we need some language extensions because Squeal uses modern GHC --- features. --- --- >>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels --- >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators --- --- We'll need some imports. --- --- >>> import Control.Monad (void) --- >>> import Control.Monad.Base (liftBase) --- >>> import Data.Int (Int32) --- >>> import Data.Text (Text) --- >>> import Squeal.PostgreSQL --- --- We'll use generics to easily convert between Haskell and PostgreSQL values. --- --- >>> import qualified Generics.SOP as SOP --- >>> import qualified GHC.Generics as GHC --- --- The first step is to define the schema of our database. This is where --- we use @DataKinds@ and @TypeOperators@. --- --- >>> :{ --- 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 --- ]) --- ] --- :} --- --- Notice the use of type operators. `:::` is used --- to pair an alias `Symbol` with either a `TableType` or a `ColumnType`. --- `:=>` is used to pair a `TableConstraint`s with a `ColumnsType`, --- yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, --- yielding a `ColumnType`. --- --- Next, we'll write `Definition`s to set up and tear down the schema. In --- Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable` --- command and has two type parameters, corresponding to the schema --- before being run and the schema after. We can compose definitions using --- `>>>`. Here and in the rest of our commands we make use of overloaded --- labels to refer to named tables and columns in our schema. --- --- >>> :{ --- let --- setup :: Definition '[] Schema --- setup = --- createTable #users --- ( serial `As` #id :* --- (text & notNullable) `As` #name :* Nil ) --- ( primaryKey #id `As` #pk_users :* Nil ) >>> --- createTable #emails --- ( serial `As` #id :* --- (int & notNullable) `As` #user_id :* --- (text & nullable) `As` #email :* Nil ) --- ( primaryKey #id `As` #pk_emails :* --- foreignKey #user_id #users #id --- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) --- :} --- --- We can easily see the generated SQL is unsuprising looking. --- --- >>> renderDefinition 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);" --- --- Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@. --- In our `createTable` commands we included `TableConstraint`s to define --- primary and foreign keys, making them somewhat complex. Our tear down --- `Definition` is simpler. --- --- >>> :{ --- let --- teardown :: Definition Schema '[] --- teardown = dropTable #emails >>> dropTable #users --- :} --- --- >>> renderDefinition teardown --- "DROP TABLE \"emails\"; DROP TABLE \"users\";" --- --- Next, we'll write `Manipulation`s to insert data into our two tables. --- A `Manipulation` is an `insertRow` (or other inserts), `update` --- or `deleteFrom` command and --- has three type parameters, the schema it refers to, a list of parameters --- it can take as input, and a list of columns it produces as output. When --- we insert into the users table, we will need a parameter for the @name@ --- field but not for the @id@ field. Since it's optional, we can use a default --- value. However, since the emails table refers to the users table, we will --- need to retrieve the user id that the insert generates and insert it into --- the emails table. Take a careful look at the type and definition of both --- of our inserts. --- --- >>> :{ --- let --- insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ] --- insertUser = insertRow #users --- (Default `As` #id :* Set (param @1) `As` #name :* Nil) --- OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) --- :} --- --- >>> :{ --- let --- insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[] --- insertEmail = insertRow #emails --- ( Default `As` #id :* --- Set (param @1) `As` #user_id :* --- Set (param @2) `As` #email :* Nil ) --- OnConflictDoNothing (Returning Nil) --- :} --- --- >>> renderManipulation insertUser --- "INSERT INTO \"users\" (\"id\", \"name\") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING \"id\" AS \"fromOnly\"" --- >>> renderManipulation insertEmail --- "INSERT INTO \"emails\" (\"id\", \"user_id\", \"email\") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING" --- --- Next we write a `Query` to retrieve users from the database. We're not --- interested in the ids here, just the usernames and email addresses. We --- need to use an inner join to get the right result. A `Query` is like a --- `Manipulation` with the same kind of type parameters. --- --- >>> :{ --- let --- getUsers :: Query Schema '[] --- '[ "userName" ::: 'NotNull 'PGtext --- , "userEmail" ::: 'Null 'PGtext ] --- getUsers = select --- (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil) --- ( from (table (#users `As` #u) --- & innerJoin (table (#emails `As` #e)) --- (#u ! #id .== #e ! #user_id)) ) --- :} --- --- >>> renderQuery getUsers --- "SELECT \"u\".\"name\" AS \"userName\", \"e\".\"email\" AS \"userEmail\" FROM \"users\" AS \"u\" INNER JOIN \"emails\" AS \"e\" ON (\"u\".\"id\" = \"e\".\"user_id\")" --- --- Now that we've defined the SQL side of things, we'll need a Haskell type --- for users. We give the type `Generics.SOP.Generic` and --- `Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows --- we receive when we run @getUsers@. Notice that the record fields of the --- @User@ type match the column names of @getUsers@. --- --- >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) --- >>> instance SOP.Generic User --- >>> instance SOP.HasDatatypeInfo User --- --- Let's also create some users to add to the database. --- --- >>> :{ --- let --- users :: [User] --- users = --- [ User "Alice" (Just "alice@gmail.com") --- , User "Bob" Nothing --- , User "Carole" (Just "carole@hotmail.com") --- ] --- :} --- --- Now we can put together all the pieces into a program. The program --- connects to the database, sets up the schema, inserts the user data --- (using prepared statements as an optimization), queries the user --- data and prints it out and finally closes the connection. We can thread --- the changing schema information through by using the indexed `PQ` monad --- transformer and when the schema doesn't change we can use `Monad` and --- `MonadPQ` functionality. --- --- >>> :{ --- let --- session :: PQ Schema Schema IO () --- session = do --- idResults <- traversePrepared insertUser (Only . userName <$> users) --- ids <- traverse (fmap fromOnly . getRow 0) idResults --- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) --- usersResult <- runQuery getUsers --- usersRows <- getRows usersResult --- liftBase $ print (usersRows :: [User]) --- :} --- --- >>> :{ --- void . withConnection "host=localhost port=5432 dbname=exampledb" $ --- define setup --- & pqThen session --- & pqThen (define teardown) --- :} --- [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] +{-| +Module: Squeal.PostgreSQL +Description: Squeel export module +Copyright: (c) Eitan Chatav, 2017 +Maintainer: eitan@morphism.tech +Stability: experimental +Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell. +Let's see an example! + +First, we need some language extensions because Squeal uses modern GHC +features. + +>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels +>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators + +We'll need some imports. + +>>> import Control.Monad (void) +>>> import Control.Monad.Base (liftBase) +>>> import Data.Int (Int32) +>>> import Data.Text (Text) +>>> import Squeal.PostgreSQL +>>> import qualified Data.ByteString.Char8 as Char8 (putStrLn) + +We'll use generics to easily convert between Haskell and PostgreSQL values. + +>>> import qualified Generics.SOP as SOP +>>> import qualified GHC.Generics as GHC + +The first step is to define the schema of our database. This is where +we use @DataKinds@ and @TypeOperators@. + +>>> :{ +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 + ]) + ] +:} + +Notice the use of type operators. `:::` is used +to pair an alias `Symbol` with either a `TableType` or a `ColumnType`. +`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`, +yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, +yielding a `ColumnType`. + +Next, we'll write `Definition`s to set up and tear down the schema. In +Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable` +command and has two type parameters, corresponding to the schema +before being run and the schema after. We can compose definitions using `>>>`. +Here and in the rest of our commands we make use of overloaded +labels to refer to named tables and columns in our schema. + +>>> :{ +let + setup :: Definition '[] Schema + setup = + createTable #users + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> + createTable #emails + ( serial `As` #id :* + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id + OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) +:} + +We can easily see the generated SQL is unsuprising looking. + +>>> Char8.putStrLn $ renderDefinition 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); + +Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@. +In our `createTable` commands we included `TableConstraint`s to define +primary and foreign keys, making them somewhat complex. Our tear down +`Definition` is simpler. + +>>> :{ +let + teardown :: Definition Schema '[] + teardown = dropTable #emails >>> dropTable #users +:} + +>>> Char8.putStrLn $ renderDefinition teardown +DROP TABLE "emails"; +DROP TABLE "users"; + +Next, we'll write `Manipulation`s to insert data into our two tables. +A `Manipulation` is an `insertRow` (or other inserts), `update` +or `deleteFrom` command and +has three type parameters, the schema it refers to, a list of parameters +it can take as input, and a list of columns it produces as output. When +we insert into the users table, we will need a parameter for the @name@ +field but not for the @id@ field. Since it's optional, we can use a default +value. However, since the emails table refers to the users table, we will +need to retrieve the user id that the insert generates and insert it into +the emails table. Take a careful look at the type and definition of both +of our inserts. + +>>> :{ +let + insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ] + insertUser = insertRow #users + (Default `As` #id :* Set (param @1) `As` #name :* Nil) + OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) +:} + +>>> :{ +let + insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[] + insertEmail = insertRow #emails + ( Default `As` #id :* + Set (param @1) `As` #user_id :* + Set (param @2) `As` #email :* Nil ) + OnConflictDoNothing (Returning Nil) +:} + +>>> Char8.putStrLn $ renderManipulation insertUser +INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly" +>>> Char8.putStrLn $ renderManipulation insertEmail +INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING + +Next we write a `Query` to retrieve users from the database. We're not +interested in the ids here, just the usernames and email addresses. We +need to use an inner join to get the right result. A `Query` is like a +`Manipulation` with the same kind of type parameters. + +>>> :{ +let + getUsers :: Query Schema '[] + '[ "userName" ::: 'NotNull 'PGtext + , "userEmail" ::: 'Null 'PGtext ] + getUsers = select + (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil) + ( from (table (#users `As` #u) + & innerJoin (table (#emails `As` #e)) + (#u ! #id .== #e ! #user_id)) ) +:} + +>>> Char8.putStrLn $ renderQuery getUsers +SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id") + +Now that we've defined the SQL side of things, we'll need a Haskell type +for users. We give the type `Generics.SOP.Generic` and +`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows +we receive when we run @getUsers@. Notice that the record fields of the +@User@ type match the column names of @getUsers@. + +>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) +>>> instance SOP.Generic User +>>> instance SOP.HasDatatypeInfo User + +Let's also create some users to add to the database. + +>>> :{ +let + users :: [User] + users = + [ User "Alice" (Just "alice@gmail.com") + , User "Bob" Nothing + , User "Carole" (Just "carole@hotmail.com") + ] +:} + +Now we can put together all the pieces into a program. The program +connects to the database, sets up the schema, inserts the user data +(using prepared statements as an optimization), queries the user +data and prints it out and finally closes the connection. We can thread +the changing schema information through by using the indexed `PQ` monad +transformer and when the schema doesn't change we can use `Monad` and +`MonadPQ` functionality. + +>>> :{ +let + session :: PQ Schema Schema IO () + session = do + idResults <- traversePrepared insertUser (Only . userName <$> users) + ids <- traverse (fmap fromOnly . getRow 0) idResults + traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) + usersResult <- runQuery getUsers + usersRows <- getRows usersResult + liftBase $ print (usersRows :: [User]) +:} + +>>> :{ +void . withConnection "host=localhost port=5432 dbname=exampledb" $ + define setup + & pqThen session + & pqThen (define teardown) +:} +[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] +-} module Squeal.PostgreSQL ( module Squeal.PostgreSQL.Binary , module Squeal.PostgreSQL.Definition diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 67860252..048a8e7b 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -116,20 +116,21 @@ newtype Definition instance Category Definition where id = UnsafeDefinition ";" ddl1 . ddl0 = UnsafeDefinition $ - renderDefinition ddl0 <+> renderDefinition ddl1 + renderDefinition ddl0 <> "\n" <> renderDefinition ddl1 {----------------------------------------- CREATE statements -----------------------------------------} --- | `createTable` adds a table to the schema. --- --- >>> :set -XOverloadedLabels --- >>> :{ --- renderDefinition $ --- createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil --- :} --- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" real NULL);" +{- | `createTable` adds a table to the schema. + +>>> :set -XOverloadedLabels +>>> :{ +Data.ByteString.Char8.putStrLn . renderDefinition $ + createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil +:} +CREATE TABLE "tab" ("a" int NULL, "b" real NULL); +-} createTable :: ( KnownSymbol table , columns ~ (col ': cols) @@ -145,18 +146,19 @@ createTable createTable tab columns constraints = UnsafeDefinition $ "CREATE TABLE" <+> renderCreation tab columns constraints --- | `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. --- Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. --- `createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`. --- --- >>> :set -XOverloadedLabels -XTypeApplications --- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] --- >>> type Schema = '["tab" ::: 'Table Table] --- >>> :{ --- renderDefinition --- (createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil :: Definition Schema Schema) --- :} --- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int NULL, \"b\" real NULL);" +{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. +Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. +`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`. + +>>> :set -XOverloadedLabels -XTypeApplications +>>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] +>>> type Schema = '["tab" ::: 'Table Table] +>>> :{ +Data.ByteString.Char8.putStrLn $ renderDefinition + (createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil :: Definition Schema Schema) +:} +CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); +-} createTableIfNotExists :: ( Has table schema ('Table (constraints :=> columns)) , SOP.SListI columns @@ -220,29 +222,30 @@ newtype TableConstraintExpression { renderTableConstraintExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) --- | 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 '[] Schema --- definition = createTable #tab --- ( (int & notNullable) `As` #a :* --- (int & notNullable) `As` #b :* Nil ) --- ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) --- :} --- --- >>> renderDefinition definition --- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));" +{-| 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 '[] Schema + definition = createTable #tab + ( (int & notNullable) `As` #a :* + (int & notNullable) `As` #b :* Nil ) + ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) +:} + +>>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); +-} check :: ( Has alias schema ('Table table) , HasAll aliases (TableToRelation table) subcolumns ) @@ -254,28 +257,29 @@ check check _cols condition = UnsafeTableConstraintExpression $ "CHECK" <+> parenthesized (renderExpression 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 '[] Schema --- definition = createTable #tab --- ( (int & nullable) `As` #a :* --- (int & nullable) `As` #b :* Nil ) --- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) --- :} --- --- >>> renderDefinition definition --- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" int NULL, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));" +{-| 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 '[] Schema + definition = createTable #tab + ( (int & nullable) `As` #a :* + (int & nullable) `As` #b :* Nil ) + ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) +:} + +>>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); +-} unique :: ( Has alias schema ('Table table) , HasAll aliases (TableToRelation table) subcolumns ) @@ -285,29 +289,30 @@ unique unique columns = UnsafeTableConstraintExpression $ "UNIQUE" <+> parenthesized (commaSeparated (renderAliases 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 '[] Schema --- definition = createTable #tab --- ( serial `As` #id :* --- (text & notNullable) `As` #name :* Nil ) --- ( primaryKey #id `As` #pk_id :* Nil ) --- :} --- --- >>> renderDefinition definition --- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));" +{-| 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 '[] Schema + definition = createTable #tab + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_id :* Nil ) +:} + +>>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); +-} primaryKey :: ( Has alias schema ('Table table) , HasAll aliases (TableToColumns table) subcolumns @@ -318,78 +323,79 @@ primaryKey primaryKey columns = UnsafeTableConstraintExpression $ "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases 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 '[] Schema --- setup = --- createTable #users --- ( serial `As` #id :* --- (text & notNullable) `As` #name :* Nil ) --- ( primaryKey #id `As` #pk_users :* Nil ) >>> --- createTable #emails --- ( serial `As` #id :* --- (int & notNullable) `As` #user_id :* --- (text & nullable) `As` #email :* Nil ) --- ( primaryKey #id `As` #pk_emails :* --- foreignKey #user_id #users #id --- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) --- in renderDefinition 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 '[] Schema --- setup = --- createTable #employees --- ( serial `As` #id :* --- (text & notNullable) `As` #name :* --- (integer & nullable) `As` #employer_id :* Nil ) --- ( primaryKey #id `As` #employees_pk :* --- foreignKey #employer_id #employees #id --- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) --- in renderDefinition 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);" --- +{-| 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 '[] Schema + setup = + createTable #users + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> + createTable #emails + ( serial `As` #id :* + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id + OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) +in Data.ByteString.Char8.putStrLn $ renderDefinition 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 '[] Schema + setup = + createTable #employees + ( serial `As` #id :* + (text & notNullable) `As` #name :* + (integer & nullable) `As` #employer_id :* Nil ) + ( primaryKey #id `As` #employees_pk :* + foreignKey #employer_id #employees #id + OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) +in Data.ByteString.Char8.putStrLn $ renderDefinition 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 schema child parent table reftable @@ -481,8 +487,8 @@ DROP statements -- definition = dropTable #muh_table -- :} -- --- >>> renderDefinition definition --- "DROP TABLE \"muh_table\";" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- DROP TABLE "muh_table"; dropTable :: Has table schema ('Table t) => Alias table -- ^ table to remove @@ -507,8 +513,8 @@ alterTable tab alteration = UnsafeDefinition $ -- | `alterTableRename` changes the name of a table from the schema. -- --- >>> renderDefinition $ alterTableRename #foo #bar --- "ALTER TABLE \"foo\" RENAME TO \"bar\";" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ alterTableRename #foo #bar +-- ALTER TABLE "foo" RENAME TO "bar"; alterTableRename :: (KnownSymbol table0, KnownSymbol table1) => Alias table0 -- ^ table to rename @@ -535,9 +541,9 @@ newtype AlterTable -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0))) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));" +-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0)); addConstraint :: ( KnownSymbol alias , Has tab schema ('Table table0) @@ -559,9 +565,9 @@ addConstraint alias constraint = UnsafeAlterTable $ -- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (dropConstraint #positive) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";" +-- ALTER TABLE "tab" DROP CONSTRAINT "positive"; dropConstraint :: ( KnownSymbol constraint , Has tab schema ('Table table0) @@ -586,9 +592,9 @@ class AddColumn ty where -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) - -- in renderDefinition definition + -- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} - -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL DEFAULT E'foo';" + -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo'; -- -- >>> :{ -- let @@ -598,9 +604,9 @@ class AddColumn ty where -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] -- definition = alterTable #tab (addColumn #col2 (text & nullable)) - -- in renderDefinition definition + -- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} - -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text NULL;" + -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; addColumn :: ( KnownSymbol column , Has tab schema ('Table table0) @@ -627,9 +633,9 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (dropColumn #col2) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";" +-- ALTER TABLE "tab" DROP COLUMN "col2"; dropColumn :: ( KnownSymbol column , Has tab schema ('Table table0) @@ -648,9 +654,9 @@ dropColumn column = UnsafeAlterTable $ -- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (renameColumn #foo #bar) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" RENAME COLUMN \"foo\" TO \"bar\";" +-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar"; renameColumn :: ( KnownSymbol column0 , KnownSymbol column1 @@ -691,9 +697,9 @@ newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnTyp -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col (setDefault 5)) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET DEFAULT 5;" +-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5; setDefault :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set -> AlterColumn schema (constraint :=> ty) ('Def :=> ty) @@ -708,9 +714,9 @@ setDefault expression = UnsafeAlterColumn $ -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropDefault) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP DEFAULT;" +-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT; dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty) dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" @@ -724,9 +730,9 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (alterColumn #col setNotNull) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET NOT NULL;" +-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; setNotNull :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) setNotNull = UnsafeAlterColumn $ "SET NOT NULL" @@ -739,9 +745,9 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropNotNull) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP NOT NULL;" +-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; dropNotNull :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" @@ -757,9 +763,9 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])] -- definition = -- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;" +-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL; alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty @@ -772,10 +778,10 @@ alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty -- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] -- definition = --- createView #bc (select (#b `As` #b :* #c `As` #c :* Nil) (from (table (#abc `As` #abc)))) --- in renderDefinition definition +-- createView #bc (select (#b :* #c :* Nil) (from (table #abc))) +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "CREATE VIEW \"bc\" AS SELECT \"b\" AS \"b\", \"c\" AS \"c\" FROM \"abc\" AS \"abc\";" +-- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; createView :: KnownSymbol view => Alias view -- ^ the name of the table to add @@ -795,9 +801,9 @@ createView alias query = UnsafeDefinition $ -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] -- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = dropView #bc --- in renderDefinition definition +-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition -- :} --- "DROP VIEW \"bc\";" +-- DROP VIEW "bc"; dropView :: Has view schema ('View v) => Alias view -- ^ view to remove @@ -806,8 +812,8 @@ dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" -- | Enumerated types are created using the `createTypeEnum` command, for example -- --- >>> renderDefinition $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) --- "CREATE TYPE \"mood\" AS ENUM ('sad', 'ok', 'happy');" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); createTypeEnum :: (KnownSymbol enum, SOP.All KnownSymbol labels) => Alias enum @@ -824,8 +830,8 @@ createTypeEnum enum labels = UnsafeDefinition $ -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> renderDefinition $ createTypeEnumWith @Schwarma #schwarma --- "CREATE TYPE \"schwarma\" AS ENUM ('Beef', 'Lamb', 'Chicken');" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeEnumWith @Schwarma #schwarma +-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); createTypeEnumWith :: forall hask enum schema. ( SOP.Generic hask @@ -841,8 +847,8 @@ createTypeEnumWith enum = createTypeEnum enum -- | `createTypeComposite` creates a composite type. The composite type is -- specified by a list of attribute names and data types. -- --- >>> renderDefinition $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) --- "CREATE TYPE \"complex\" AS (\"real\" float8, \"imaginary\" float8);" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) +-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); createTypeComposite :: (KnownSymbol ty, SOP.SListI fields) => Alias ty @@ -863,8 +869,8 @@ createTypeComposite ty fields = UnsafeDefinition $ -- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic -- >>> instance SOP.Generic Complex -- >>> instance SOP.HasDatatypeInfo Complex --- >>> renderDefinition $ createTypeCompositeWith @Complex #complex --- "CREATE TYPE \"complex\" AS (\"real\" float8, \"imaginary\" float8);" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeCompositeWith @Complex #complex +-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); createTypeCompositeWith :: forall hask ty schema. ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask) @@ -884,8 +890,8 @@ createTypeCompositeWith ty = createTypeComposite ty $ zipAs -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> renderDefinition (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[]) --- "DROP TYPE \"schwarma\";" +-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[]) +-- DROP TYPE "schwarma"; dropType :: Has tydef schema ('Typedef ty) => Alias tydef From 5f2840c3b0e79e66512ccc73de40a18124dc8460 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 17:26:31 -0700 Subject: [PATCH 54/92] printSQL and docs --- .../src/Squeal/PostgreSQL/Definition.hs | 61 +++-- .../src/Squeal/PostgreSQL/Expression.hs | 250 +++++++++--------- .../src/Squeal/PostgreSQL/Render.hs | 13 +- 3 files changed, 173 insertions(+), 151 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 048a8e7b..10a40fcc 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -113,6 +113,9 @@ newtype Definition = UnsafeDefinition { renderDefinition :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Definition schema0 schema1) where + renderSQL = renderDefinition + instance Category Definition where id = UnsafeDefinition ";" ddl1 . ddl0 = UnsafeDefinition $ @@ -126,7 +129,7 @@ CREATE statements >>> :set -XOverloadedLabels >>> :{ -Data.ByteString.Char8.putStrLn . renderDefinition $ +printSQL $ createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil :} CREATE TABLE "tab" ("a" int NULL, "b" real NULL); @@ -154,8 +157,10 @@ Instead, the schema already has the table so if the table did not yet exist, the >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] >>> type Schema = '["tab" ::: 'Table Table] >>> :{ -Data.ByteString.Char8.putStrLn $ renderDefinition - (createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil :: Definition Schema Schema) +let + setup :: Definition Schema Schema + setup = createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil +in printSQL setup :} CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); -} @@ -243,7 +248,7 @@ let ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil ) :} ->>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +>>> printSQL definition CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); -} check @@ -277,7 +282,7 @@ let ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil ) :} ->>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +>>> printSQL definition CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); -} unique @@ -310,7 +315,7 @@ let ( primaryKey #id `As` #pk_id :* Nil ) :} ->>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +>>> printSQL definition CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); -} primaryKey @@ -361,7 +366,7 @@ let ( primaryKey #id `As` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) -in Data.ByteString.Char8.putStrLn $ renderDefinition setup +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); @@ -392,7 +397,7 @@ let ( primaryKey #id `As` #employees_pk :* foreignKey #employer_id #employees #id OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil ) -in Data.ByteString.Char8.putStrLn $ renderDefinition setup +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); -} @@ -487,7 +492,7 @@ DROP statements -- definition = dropTable #muh_table -- :} -- --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- >>> printSQL definition -- DROP TABLE "muh_table"; dropTable :: Has table schema ('Table t) @@ -513,7 +518,7 @@ alterTable tab alteration = UnsafeDefinition $ -- | `alterTableRename` changes the name of a table from the schema. -- --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ alterTableRename #foo #bar +-- >>> printSQL $ alterTableRename #foo #bar -- ALTER TABLE "foo" RENAME TO "bar"; alterTableRename :: (KnownSymbol table0, KnownSymbol table1) @@ -541,7 +546,7 @@ newtype AlterTable -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0))) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0)); addConstraint @@ -565,7 +570,7 @@ addConstraint alias constraint = UnsafeAlterTable $ -- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (dropConstraint #positive) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" DROP CONSTRAINT "positive"; dropConstraint @@ -592,7 +597,7 @@ class AddColumn ty where -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'Def :=> 'Null 'PGtext ])] -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) - -- in Data.ByteString.Char8.putStrLn $ renderDefinition definition + -- in printSQL definition -- :} -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo'; -- @@ -604,7 +609,7 @@ class AddColumn ty where -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] -- definition = alterTable #tab (addColumn #col2 (text & nullable)) - -- in Data.ByteString.Char8.putStrLn $ renderDefinition definition + -- in printSQL definition -- :} -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; addColumn @@ -633,7 +638,7 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])] -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (dropColumn #col2) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" DROP COLUMN "col2"; dropColumn @@ -654,7 +659,7 @@ dropColumn column = UnsafeAlterTable $ -- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (renameColumn #foo #bar) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar"; renameColumn @@ -697,7 +702,7 @@ newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnTyp -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col (setDefault 5)) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5; setDefault @@ -714,7 +719,7 @@ setDefault expression = UnsafeAlterColumn $ -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropDefault) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT; dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty) @@ -730,7 +735,7 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- definition = alterTable #tab (alterColumn #col setNotNull) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; setNotNull @@ -745,7 +750,7 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])] -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = alterTable #tab (alterColumn #col dropNotNull) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; dropNotNull @@ -763,7 +768,7 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])] -- definition = -- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL; alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty @@ -779,7 +784,7 @@ alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] -- definition = -- createView #bc (select (#b :* #c :* Nil) (from (table #abc))) --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; createView @@ -801,7 +806,7 @@ createView alias query = UnsafeDefinition $ -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])] -- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])] -- definition = dropView #bc --- in Data.ByteString.Char8.putStrLn $ renderDefinition definition +-- in printSQL definition -- :} -- DROP VIEW "bc"; dropView @@ -812,7 +817,7 @@ dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";" -- | Enumerated types are created using the `createTypeEnum` command, for example -- --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +-- >>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) -- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); createTypeEnum :: (KnownSymbol enum, SOP.All KnownSymbol labels) @@ -830,7 +835,7 @@ createTypeEnum enum labels = UnsafeDefinition $ -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeEnumWith @Schwarma #schwarma +-- >>> printSQL $ createTypeEnumWith @Schwarma #schwarma -- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); createTypeEnumWith :: forall hask enum schema. @@ -847,7 +852,7 @@ createTypeEnumWith enum = createTypeEnum enum -- | `createTypeComposite` creates a composite type. The composite type is -- specified by a list of attribute names and data types. -- --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) +-- >>> printSQL $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) -- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); createTypeComposite :: (KnownSymbol ty, SOP.SListI fields) @@ -869,7 +874,7 @@ createTypeComposite ty fields = UnsafeDefinition $ -- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic -- >>> instance SOP.Generic Complex -- >>> instance SOP.HasDatatypeInfo Complex --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeCompositeWith @Complex #complex +-- >>> printSQL $ createTypeCompositeWith @Complex #complex -- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); createTypeCompositeWith :: forall hask ty schema. @@ -890,7 +895,7 @@ createTypeCompositeWith ty = createTypeComposite ty $ zipAs -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> Data.ByteString.Char8.putStrLn $ renderDefinition (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[]) +-- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[]) -- DROP TYPE "schwarma"; dropType :: Has tydef schema ('Typedef ty) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index dd44e9e7..c0dc86df 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -172,6 +172,9 @@ newtype Expression = UnsafeExpression { renderExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Expression schema relations grouping params ty) where + renderSQL = renderExpression + {- | A `HasParameter` constraint is used to indicate a value that is supplied externally to a SQL statement. `Squeal.PostgreSQL.PQ.manipulateParams`, @@ -278,15 +281,15 @@ instance -- | analagous to `Nothing` -- --- >>> renderExpression $ null_ --- "NULL" +-- >>> printSQL null_ +-- NULL null_ :: Expression schema rels grouping params ('Null ty) null_ = UnsafeExpression "NULL" -- | analagous to `Just` -- --- >>> renderExpression $ notNull true --- "TRUE" +-- >>> printSQL $ notNull true +-- TRUE notNull :: Expression schema rels grouping params ('NotNull ty) -> Expression schema rels grouping params ('Null ty) @@ -294,8 +297,8 @@ notNull = UnsafeExpression . renderExpression -- | return the leftmost value which is not NULL -- --- >>> renderExpression $ coalesce [null_, notNull true] false --- "COALESCE(NULL, TRUE, FALSE)" +-- >>> printSQL $ coalesce [null_, notNull true] false +-- COALESCE(NULL, TRUE, FALSE) coalesce :: [Expression schema relations grouping params ('Null ty)] -- ^ @NULL@s may be present @@ -308,8 +311,8 @@ coalesce nullxs notNullx = UnsafeExpression $ -- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@ -- --- >>> renderExpression $ fromNull true null_ --- "COALESCE(NULL, TRUE)" +-- >>> printSQL $ fromNull true null_ +-- COALESCE(NULL, TRUE) fromNull :: Expression schema relations grouping params ('NotNull ty) -- ^ what to convert @NULL@ to @@ -317,16 +320,16 @@ fromNull -> Expression schema relations grouping params ('NotNull ty) fromNull notNullx nullx = coalesce [nullx] notNullx --- | >>> renderExpression $ null_ & isNull --- "NULL IS NULL" +-- | >>> printSQL $ null_ & isNull +-- NULL IS NULL isNull :: Expression schema relations grouping params ('Null ty) -- ^ possibly @NULL@ -> Condition schema relations grouping params isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL" --- | >>> renderExpression $ null_ & isNotNull --- "NULL IS NOT NULL" +-- | >>> printSQL $ null_ & isNotNull +-- NULL IS NOT NULL isNotNull :: Expression schema relations grouping params ('Null ty) -- ^ possibly @NULL@ @@ -335,8 +338,8 @@ isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@ -- --- >>> renderExpression $ matchNull true not_ null_ --- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END" +-- >>> printSQL $ matchNull true not_ null_ +-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END matchNull :: Expression schema relations grouping params (nullty) -- ^ what to convert @NULL@ to @@ -348,12 +351,14 @@ matchNull matchNull y f x = ifThenElse (isNull x) y (f (UnsafeExpression (renderExpression x))) --- | right inverse to `fromNull`, if its arguments are equal then --- `nullIf` gives @NULL@. --- --- >>> :set -XTypeApplications -XDataKinds --- >>> renderExpression @'[] @_ @_ @'[_] $ fromNull false (nullIf false (param @1)) --- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)" +{-| right inverse to `fromNull`, if its arguments are equal then +`nullIf` gives @NULL@. + +>>> :set -XTypeApplications -XDataKinds +>>> let expr = nullIf false (param @1) :: Expression schema rels grp '[ 'NotNull 'PGbool] ('Null 'PGbool) +>>> printSQL expr +NULL IF (FALSE, ($1 :: bool)) +-} nullIf :: Expression schema relations grouping params ('NotNull ty) -- ^ @NULL@ is absent @@ -363,8 +368,8 @@ nullIf nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized (renderExpression x <> ", " <> renderExpression y) --- | >>> renderExpression $ array [null_, notNull false, notNull true] --- "ARRAY[NULL, FALSE, TRUE]" +-- | >>> printSQL $ array [null_, notNull false, notNull true] +-- ARRAY[NULL, FALSE, TRUE] array :: [Expression schema relations grouping params ('Null ty)] -- ^ array elements @@ -381,8 +386,8 @@ instance (KnownSymbol label, label `In` labels) => IsPGlabel label -- -- >>> type Complex = PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8] -- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex) --- >>> renderExpression i --- "ROW(0, 1)" +-- >>> printSQL i +-- ROW(0, 1) row :: SListI (Nulls fields) => NP (Aliased (Expression schema relations grouping params)) (Nulls fields) @@ -407,8 +412,9 @@ instance Monoid mempty = array [] mappend = (<>) --- | >>> renderExpression @'[] @_ @_ @'[_] $ greatest currentTimestamp [param @1] --- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))" +-- | >>> let expr = greatest currentTimestamp [param @1] :: Expression sch rels grp '[ 'NotNull 'PGtimestamptz] ('NotNull 'PGtimestamptz) +-- >>> printSQL expr +-- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone)) greatest :: Expression schema relations grouping params (nullty) -- ^ needs at least 1 argument @@ -418,8 +424,8 @@ greatest greatest x xs = UnsafeExpression $ "GREATEST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" --- | >>> renderExpression $ least currentTimestamp [null_] --- "LEAST(CURRENT_TIMESTAMP, NULL)" +-- | >>> printSQL $ least currentTimestamp [null_] +-- LEAST(CURRENT_TIMESTAMP, NULL) least :: Expression schema relations grouping params (nullty) -- ^ needs at least 1 argument @@ -429,8 +435,8 @@ least least x xs = UnsafeExpression $ "LEAST(" <> commaSeparated (renderExpression <$> (x:xs)) <> ")" --- | >>> renderExpression $ unsafeBinaryOp "OR" true false --- "(TRUE OR FALSE)" +-- | >>> printSQL $ unsafeBinaryOp "OR" true false +-- (TRUE OR FALSE) unsafeBinaryOp :: ByteString -- ^ operator @@ -440,8 +446,8 @@ unsafeBinaryOp unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ renderExpression x <+> op <+> renderExpression y --- | >>> renderExpression $ unsafeUnaryOp "NOT" true --- "(NOT TRUE)" +-- | >>> printSQL $ unsafeUnaryOp "NOT" true +-- (NOT TRUE) unsafeUnaryOp :: ByteString -- ^ operator @@ -450,8 +456,8 @@ unsafeUnaryOp unsafeUnaryOp op x = UnsafeExpression $ parenthesized $ op <+> renderExpression x --- | >>> renderExpression $ unsafeFunction "f" true --- "f(TRUE)" +-- | >>> printSQL $ unsafeFunction "f" true +-- f(TRUE) unsafeFunction :: ByteString -- ^ function @@ -503,9 +509,9 @@ instance (PGNum ty, PGFloating ty) => Floating -- let -- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = atan2_ pi 2 --- in renderExpression expression +-- in printSQL expression -- :} --- "atan2(pi(), 2)" +-- atan2(pi(), 2) atan2_ :: PGFloating float => Expression schema relations grouping params (nullity float) @@ -520,8 +526,8 @@ atan2_ y x = UnsafeExpression $ -- represents a run-time type conversion. The cast will succeed only if a -- suitable type conversion operation has been defined. -- --- | >>> renderExpression $ true & cast int4 --- "(TRUE :: int4)" +-- | >>> printSQL $ true & cast int4 +-- (TRUE :: int4) cast :: TypeExpression schema ty1 -- ^ type to cast as @@ -537,9 +543,9 @@ cast ty x = UnsafeExpression $ parenthesized $ -- let -- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = 5 `quot_` 2 --- in renderExpression expression +-- in printSQL expression -- :} --- "(5 / 2)" +-- (5 / 2) quot_ :: PGIntegral int => Expression schema relations grouping params (nullity int) @@ -555,9 +561,9 @@ quot_ = unsafeBinaryOp "/" -- let -- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = 5 `rem_` 2 --- in renderExpression expression +-- in printSQL expression -- :} --- "(5 % 2)" +-- (5 % 2) rem_ :: PGIntegral int => Expression schema relations grouping params (nullity int) @@ -571,9 +577,9 @@ rem_ = unsafeBinaryOp "%" -- let -- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = trunc pi --- in renderExpression expression +-- in printSQL expression -- :} --- "trunc(pi())" +-- trunc(pi()) trunc :: PGFloating frac => Expression schema relations grouping params (nullity frac) @@ -585,9 +591,9 @@ trunc = unsafeFunction "trunc" -- let -- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = round_ pi --- in renderExpression expression +-- in printSQL expression -- :} --- "round(pi())" +-- round(pi()) round_ :: PGFloating frac => Expression schema relations grouping params (nullity frac) @@ -599,9 +605,9 @@ round_ = unsafeFunction "round" -- let -- expression :: Expression schema relations grouping params (nullity 'PGfloat4) -- expression = ceiling_ pi --- in renderExpression expression +-- in printSQL expression -- :} --- "ceiling(pi())" +-- ceiling(pi()) ceiling_ :: PGFloating frac => Expression schema relations grouping params (nullity frac) @@ -616,33 +622,33 @@ ceiling_ = unsafeFunction "ceiling" type Condition schema relations grouping params = Expression schema relations grouping params ('NotNull 'PGbool) --- | >>> renderExpression true --- "TRUE" +-- | >>> printSQL true +-- TRUE true :: Condition schema relations grouping params true = UnsafeExpression "TRUE" --- | >>> renderExpression false --- "FALSE" +-- | >>> printSQL false +-- FALSE false :: Condition schema relations grouping params false = UnsafeExpression "FALSE" --- | >>> renderExpression $ not_ true --- "(NOT TRUE)" +-- | >>> printSQL $ not_ true +-- (NOT TRUE) not_ :: Condition schema relations grouping params -> Condition schema relations grouping params not_ = unsafeUnaryOp "NOT" --- | >>> renderExpression $ true .&& false --- "(TRUE AND FALSE)" +-- | >>> printSQL $ true .&& false +-- (TRUE AND FALSE) (.&&) :: Condition schema relations grouping params -> Condition schema relations grouping params -> Condition schema relations grouping params (.&&) = unsafeBinaryOp "AND" --- | >>> renderExpression $ true .|| false --- "(TRUE OR FALSE)" +-- | >>> printSQL $ true .|| false +-- (TRUE OR FALSE) (.||) :: Condition schema relations grouping params -> Condition schema relations grouping params @@ -653,9 +659,9 @@ not_ = unsafeUnaryOp "NOT" -- let -- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 --- in renderExpression expression +-- in printSQL expression -- :} --- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END" +-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END caseWhenThenElse :: [ ( Condition schema relations grouping params , Expression schema relations grouping params (ty) @@ -681,9 +687,9 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat -- let -- expression :: Expression schema relations grouping params (nullity 'PGint2) -- expression = ifThenElse true 1 0 --- in renderExpression expression +-- in printSQL expression -- :} --- "CASE WHEN TRUE THEN 1 ELSE 0 END" +-- CASE WHEN TRUE THEN 1 ELSE 0 END ifThenElse :: Condition schema relations grouping params -> Expression schema relations grouping params (ty) -- ^ then @@ -694,8 +700,8 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=` -- will produce @NULL@s if one of their arguments is @NULL@. -- --- >>> renderExpression $ notNull true .== null_ --- "(TRUE = NULL)" +-- >>> printSQL $ notNull true .== null_ +-- (TRUE = NULL) (.==) :: Expression schema relations grouping params (nullity ty) -- ^ lhs -> Expression schema relations grouping params (nullity ty) -- ^ rhs @@ -703,8 +709,8 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ (.==) = unsafeBinaryOp "=" infix 4 .== --- | >>> renderExpression $ notNull true ./= null_ --- "(TRUE <> NULL)" +-- | >>> printSQL $ notNull true ./= null_ +-- (TRUE <> NULL) (./=) :: Expression schema relations grouping params (nullity ty) -- ^ lhs -> Expression schema relations grouping params (nullity ty) -- ^ rhs @@ -712,8 +718,8 @@ infix 4 .== (./=) = unsafeBinaryOp "<>" infix 4 ./= --- | >>> renderExpression $ notNull true .>= null_ --- "(TRUE >= NULL)" +-- | >>> printSQL $ notNull true .>= null_ +-- (TRUE >= NULL) (.>=) :: Expression schema relations grouping params (nullity ty) -- ^ lhs -> Expression schema relations grouping params (nullity ty) -- ^ rhs @@ -721,8 +727,8 @@ infix 4 ./= (.>=) = unsafeBinaryOp ">=" infix 4 .>= --- | >>> renderExpression $ notNull true .< null_ --- "(TRUE < NULL)" +-- | >>> printSQL $ notNull true .< null_ +-- (TRUE < NULL) (.<) :: Expression schema relations grouping params (nullity ty) -- ^ lhs -> Expression schema relations grouping params (nullity ty) -- ^ rhs @@ -730,8 +736,8 @@ infix 4 .>= (.<) = unsafeBinaryOp "<" infix 4 .< --- | >>> renderExpression $ notNull true .<= null_ --- "(TRUE <= NULL)" +-- | >>> printSQL $ notNull true .<= null_ +-- (TRUE <= NULL) (.<=) :: Expression schema relations grouping params (nullity ty) -- ^ lhs -> Expression schema relations grouping params (nullity ty) -- ^ rhs @@ -739,8 +745,8 @@ infix 4 .< (.<=) = unsafeBinaryOp "<=" infix 4 .<= --- | >>> renderExpression $ notNull true .> null_ --- "(TRUE > NULL)" +-- | >>> printSQL $ notNull true .> null_ +-- (TRUE > NULL) (.>) :: Expression schema relations grouping params (nullity ty) -- ^ lhs -> Expression schema relations grouping params (nullity ty) -- ^ rhs @@ -748,32 +754,32 @@ infix 4 .<= (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> renderExpression currentDate --- "CURRENT_DATE" +-- | >>> printSQL currentDate +-- CURRENT_DATE currentDate :: Expression schema relations grouping params (nullity 'PGdate) currentDate = UnsafeExpression "CURRENT_DATE" --- | >>> renderExpression currentTime --- "CURRENT_TIME" +-- | >>> printSQL currentTime +-- CURRENT_TIME currentTime :: Expression schema relations grouping params (nullity 'PGtimetz) currentTime = UnsafeExpression "CURRENT_TIME" --- | >>> renderExpression currentTimestamp --- "CURRENT_TIMESTAMP" +-- | >>> printSQL currentTimestamp +-- CURRENT_TIMESTAMP currentTimestamp :: Expression schema relations grouping params (nullity 'PGtimestamptz) currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP" --- | >>> renderExpression localTime --- "LOCALTIME" +-- | >>> printSQL localTime +-- LOCALTIME localTime :: Expression schema relations grouping params (nullity 'PGtime) localTime = UnsafeExpression "LOCALTIME" --- | >>> renderExpression localTimestamp --- "LOCALTIMESTAMP" +-- | >>> printSQL localTimestamp +-- LOCALTIMESTAMP localTimestamp :: Expression schema relations grouping params (nullity 'PGtimestamp) localTimestamp = UnsafeExpression "LOCALTIMESTAMP" @@ -807,24 +813,24 @@ instance Monoid mempty = fromString "" mappend = (<>) --- | >>> renderExpression $ lower "ARRRGGG" --- "lower(E'ARRRGGG')" +-- | >>> printSQL $ lower "ARRRGGG" +-- lower(E'ARRRGGG') lower :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to lower case -> Expression schema relations grouping params (nullity 'PGtext) lower = unsafeFunction "lower" --- | >>> renderExpression $ upper "eeee" --- "upper(E'eeee')" +-- | >>> printSQL $ upper "eeee" +-- upper(E'eeee') upper :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to upper case -> Expression schema relations grouping params (nullity 'PGtext) upper = unsafeFunction "upper" --- | >>> renderExpression $ charLength "four" --- "char_length(E'four')" +-- | >>> printSQL $ charLength "four" +-- char_length(E'four') charLength :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string to measure @@ -838,8 +844,8 @@ charLength = unsafeFunction "char_length" -- in pattern stands for (matches) any single character; a percent sign (%) -- matches any sequence of zero or more characters. -- --- >>> renderExpression $ "abc" `like` "a%" --- "(E'abc' LIKE E'a%')" +-- >>> printSQL $ "abc" `like` "a%" +-- (E'abc' LIKE E'a%') like :: Expression schema relations grouping params (nullity 'PGtext) -- ^ string @@ -872,9 +878,9 @@ unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat -- let -- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric) -- expression = sum_ #col --- in renderExpression expression +-- in printSQL expression -- :} --- "sum(\"col\")" +-- sum("col") sum_ :: PGNum ty => Expression schema relations 'Ungrouped params (nullity ty) @@ -886,9 +892,9 @@ sum_ = unsafeAggregate "sum" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric) -- expression = sumDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "sum(DISTINCT \"col\")" +-- sum(DISTINCT "col") sumDistinct :: PGNum ty => Expression schema relations 'Ungrouped params (nullity ty) @@ -917,9 +923,9 @@ instance PGAvg 'PGinterval 'PGinterval -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitAnd #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_and(\"col\")" +-- bit_and("col") bitAnd :: PGIntegral int => Expression schema relations 'Ungrouped params (nullity int) @@ -931,9 +937,9 @@ bitAnd = unsafeAggregate "bit_and" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitOr #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_or(\"col\")" +-- bit_or("col") bitOr :: PGIntegral int => Expression schema relations 'Ungrouped params (nullity int) @@ -945,9 +951,9 @@ bitOr = unsafeAggregate "bit_or" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitAndDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_and(DISTINCT \"col\")" +-- bit_and(DISTINCT "col") bitAndDistinct :: PGIntegral int => Expression schema relations 'Ungrouped params (nullity int) @@ -959,9 +965,9 @@ bitAndDistinct = unsafeAggregateDistinct "bit_and" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4) -- expression = bitOrDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bit_or(DISTINCT \"col\")" +-- bit_or(DISTINCT "col") bitOrDistinct :: PGIntegral int => Expression schema relations 'Ungrouped params (nullity int) @@ -973,9 +979,9 @@ bitOrDistinct = unsafeAggregateDistinct "bit_or" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolAnd #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_and(\"col\")" +-- bool_and("col") boolAnd :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate @@ -986,9 +992,9 @@ boolAnd = unsafeAggregate "bool_and" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolOr #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_or(\"col\")" +-- bool_or("col") boolOr :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate @@ -999,9 +1005,9 @@ boolOr = unsafeAggregate "bool_or" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolAndDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_and(DISTINCT \"col\")" +-- bool_and(DISTINCT "col") boolAndDistinct :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate @@ -1012,9 +1018,9 @@ boolAndDistinct = unsafeAggregateDistinct "bool_and" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = boolOrDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "bool_or(DISTINCT \"col\")" +-- bool_or(DISTINCT "col") boolOrDistinct :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate @@ -1023,8 +1029,8 @@ boolOrDistinct = unsafeAggregateDistinct "bool_or" -- | A special aggregation that does not require an input -- --- >>> renderExpression countStar --- "count(*)" +-- >>> printSQL countStar +-- count(*) countStar :: Expression schema relations ('Grouped bys) params ('NotNull 'PGint8) countStar = UnsafeExpression $ "count(*)" @@ -1033,9 +1039,9 @@ countStar = UnsafeExpression $ "count(*)" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) -- expression = count #col --- in renderExpression expression +-- in printSQL expression -- :} --- "count(\"col\")" +-- count("col") count :: Expression schema relations 'Ungrouped params ty -- ^ what to count @@ -1046,9 +1052,9 @@ count = unsafeAggregate "count" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8) -- expression = countDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "count(DISTINCT \"col\")" +-- count(DISTINCT "col") countDistinct :: Expression schema relations 'Ungrouped params ty -- ^ what to count @@ -1061,9 +1067,9 @@ countDistinct = unsafeAggregateDistinct "count" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = every #col --- in renderExpression expression +-- in printSQL expression -- :} --- "every(\"col\")" +-- every("col") every :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate @@ -1076,9 +1082,9 @@ every = unsafeAggregate "every" -- let -- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool) -- expression = everyDistinct #col --- in renderExpression expression +-- in printSQL expression -- :} --- "every(DISTINCT \"col\")" +-- every(DISTINCT "col") everyDistinct :: Expression schema relations 'Ungrouped params (nullity 'PGbool) -- ^ what to aggregate diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs index f20aba12..eae11641 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs @@ -9,7 +9,8 @@ Rendering helper functions. -} {-# LANGUAGE - MagicHash + FlexibleContexts + , MagicHash , OverloadedStrings , PolyKinds , RankNTypes @@ -25,8 +26,11 @@ module Squeal.PostgreSQL.Render , renderCommaSeparated , renderCommaSeparatedMaybe , renderNat + , RenderSQL (..) + , printSQL ) where +import Control.Monad.Base import Data.ByteString (ByteString) import Data.Maybe import Data.Monoid ((<>)) @@ -35,6 +39,7 @@ import GHC.Exts import GHC.TypeLits import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 -- | Parenthesize a `ByteString`. parenthesized :: ByteString -> ByteString @@ -77,3 +82,9 @@ renderCommaSeparatedMaybe render -- | Render a promoted `Nat`. renderNat :: KnownNat n => proxy n -> ByteString renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n))) + +class RenderSQL sql where + renderSQL :: sql -> ByteString + +printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io () +printSQL = liftBase . Char8.putStrLn . renderSQL From 0a30cfeaaf1229591404a452af8785612720915f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 17:36:24 -0700 Subject: [PATCH 55/92] manipulation docs --- .../src/Squeal/PostgreSQL/Manipulation.hs | 35 ++++++++++--------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index fcc291a0..f758fdcf 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -73,9 +73,9 @@ let , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[] manipulation = insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT)" +INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) parameterized insert: @@ -89,9 +89,9 @@ let manipulation = insertRow_ #tab (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4))" +INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4)) returning insert: @@ -105,9 +105,9 @@ let manipulation = insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil) OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil)) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\"" +INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) RETURNING "col1" AS "fromOnly" upsert: @@ -126,9 +126,9 @@ let (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) [#col1 .== #col2]) (Returning $ (#col1 + #col2) `As` #sum :* Nil) -in renderManipulation manipulation +in printSQL manipulation :} -"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\"" +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" query insert: @@ -147,9 +147,9 @@ let manipulation = insertQuery_ #tab (selectStar (from (table (#other_tab `As` #t)))) -in renderManipulation manipulation +in printSQL manipulation :} -"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\"" +INSERT INTO "tab" SELECT * FROM "other_tab" AS "t" update: @@ -162,9 +162,9 @@ let manipulation = update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) (#col1 ./= #col2) -in renderManipulation manipulation +in printSQL manipulation :} -"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\")" +UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2") delete: @@ -177,9 +177,9 @@ let '[ "col1" ::: 'NotNull 'PGint4 , "col2" ::: 'NotNull 'PGint4 ] manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar -in renderManipulation manipulation +in printSQL manipulation :} -"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *" +DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING * -} newtype Manipulation (schema :: SchemaType) @@ -188,6 +188,9 @@ newtype Manipulation = UnsafeManipulation { renderManipulation :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Manipulation schema params columns) where + renderSQL = renderManipulation + -- | Convert a `Query` into a `Manipulation`. queryStatement :: Query schema params columns @@ -483,9 +486,9 @@ WITH statements -- manipulation = with -- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil) -- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t))))) --- in renderManipulation manipulation +-- in printSQL manipulation -- :} --- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\"" +-- WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t" with :: SOP.SListI commons => NP (Aliased (Manipulation schema params)) commons From da4f6c6a6af466d1e68fdc1155f242a9a28efc46 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 17:43:06 -0700 Subject: [PATCH 56/92] query docs --- .../src/Squeal/PostgreSQL/Query.hs | 45 ++++++++++--------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs index 3b29231f..247094f7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs @@ -99,9 +99,9 @@ let '[] '["col" ::: 'Null 'PGint4] query = selectStar (from (table #tab)) -in renderQuery query +in printSQL query :} -"SELECT * FROM \"tab\" AS \"tab\"" +SELECT * FROM "tab" AS "tab" restricted query: @@ -120,9 +120,9 @@ let ( from (table #tab) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) ) -in renderQuery query +in printSQL query :} -"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"tab\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))" +SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0)) subquery: @@ -135,9 +135,9 @@ let query = selectStar (from (subquery (selectStar (from (table #tab)) `As` #sub))) -in renderQuery query +in printSQL query :} -"SELECT * FROM (SELECT * FROM \"tab\" AS \"tab\") AS \"sub\"" +SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub" limits and offsets: @@ -149,9 +149,9 @@ let '["col" ::: 'Null 'PGint4] query = selectStar (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2) -in renderQuery query +in printSQL query :} -"SELECT * FROM \"tab\" AS \"tab\" LIMIT 50 OFFSET 4" +SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4 parameterized query: @@ -163,9 +163,9 @@ let '["col" ::: 'NotNull 'PGfloat8] query = selectStar (from (table #tab) & where_ (#col .> param @1)) -in renderQuery query +in printSQL query :} -"SELECT * FROM \"tab\" AS \"tab\" WHERE (\"col\" > ($1 :: float8))" +SELECT * FROM "tab" AS "tab" WHERE ("col" > ($1 :: float8)) aggregation query: @@ -183,9 +183,9 @@ let ( from (table (#tab `As` #table1)) & group (By #col1 :* Nil) & having (#col1 + sum_ #col2 .> 1) ) -in renderQuery query +in printSQL query :} -"SELECT sum(\"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"table1\" GROUP BY \"col1\" HAVING ((\"col1\" + sum(\"col2\")) > 1)" +SELECT sum("col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum("col2")) > 1) sorted query: @@ -197,9 +197,9 @@ let '["col" ::: 'Null 'PGint4] query = selectStar (from (table #tab) & orderBy [#col & AscNullsFirst]) -in renderQuery query +in printSQL query :} -"SELECT * FROM \"tab\" AS \"tab\" ORDER BY \"col\" ASC NULLS FIRST" +SELECT * FROM "tab" AS "tab" ORDER BY "col" ASC NULLS FIRST joins: @@ -241,9 +241,9 @@ let (#o ! #customer_id .== #c ! #id) & innerJoin (table (#shippers `As` #s)) (#o ! #shipper_id .== #s ! #id)) ) -in renderQuery query +in printSQL query :} -"SELECT \"o\".\"price\" AS \"order_price\", \"c\".\"name\" AS \"customer_name\", \"s\".\"name\" AS \"shipper_name\" FROM \"orders\" AS \"o\" INNER JOIN \"customers\" AS \"c\" ON (\"o\".\"customer_id\" = \"c\".\"id\") INNER JOIN \"shippers\" AS \"s\" ON (\"o\".\"shipper_id\" = \"s\".\"id\")" +SELECT "o"."price" AS "order_price", "c"."name" AS "customer_name", "s"."name" AS "shipper_name" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id") self-join: @@ -255,9 +255,9 @@ let '["col" ::: 'Null 'PGint4] query = selectDotStar #t1 (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2)))) -in renderQuery query +in printSQL query :} -"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\"" +SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2" set operations: @@ -271,9 +271,9 @@ let selectStar (from (table #tab)) `unionAll` selectStar (from (table #tab)) -in renderQuery query +in printSQL query :} -"(SELECT * FROM \"tab\" AS \"tab\") UNION ALL (SELECT * FROM \"tab\" AS \"tab\")" +(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab") -} newtype Query (schema :: SchemaType) @@ -281,6 +281,7 @@ newtype Query (columns :: RelationType) = UnsafeQuery { renderQuery :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) +instance RenderSQL (Query schema params columns) where renderSQL = renderQuery -- | The results of two queries can be combined using the set operation -- `union`. Duplicate rows are eliminated. @@ -434,8 +435,8 @@ selectDistinctDotStar rel relations = UnsafeQuery $ -- -- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext] -- >>> let query = values (1 `As` #a :* "one" `As` #b :* Nil) [] :: Query '[] '[] Row --- >>> renderQuery query --- "SELECT * FROM (VALUES (1, E'one')) AS t (\"a\", \"b\")" +-- >>> printSQL query +-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b") values :: SListI cols => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols From ddeb75d369ce226762e40f8f1783c2641f600ad7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 17:47:14 -0700 Subject: [PATCH 57/92] renderSQL for Alias --- squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 21ddd6f4..b9781285 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -365,6 +365,7 @@ instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where fromLabel = Alias instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where fromLabel = fromLabel :* Nil +instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias -- | >>> renderAlias #jimbob -- "\"jimbob\"" From e013ff3e18485ece5fd6fb52bfb367b3ef7faba6 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 17:59:45 -0700 Subject: [PATCH 58/92] docs --- squeal-postgresql/src/Squeal/PostgreSQL.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 0fd83a3d..07f61416 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -21,7 +21,6 @@ We'll need some imports. >>> import Data.Int (Int32) >>> import Data.Text (Text) >>> import Squeal.PostgreSQL ->>> import qualified Data.ByteString.Char8 as Char8 (putStrLn) We'll use generics to easily convert between Haskell and PostgreSQL values. @@ -81,13 +80,13 @@ let We can easily see the generated SQL is unsuprising looking. ->>> Char8.putStrLn $ renderDefinition setup +>>> 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); Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@. In our `createTable` commands we included `TableConstraint`s to define -primary and foreign keys, making them somewhat complex. Our tear down +primary and foreign keys, making them somewhat complex. Our @teardown@ `Definition` is simpler. >>> :{ @@ -96,7 +95,7 @@ let teardown = dropTable #emails >>> dropTable #users :} ->>> Char8.putStrLn $ renderDefinition teardown +>>> printSQL teardown DROP TABLE "emails"; DROP TABLE "users"; @@ -130,9 +129,9 @@ let OnConflictDoNothing (Returning Nil) :} ->>> Char8.putStrLn $ renderManipulation insertUser +>>> printSQL insertUser INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly" ->>> Char8.putStrLn $ renderManipulation insertEmail +>>> printSQL insertEmail INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING Next we write a `Query` to retrieve users from the database. We're not @@ -152,7 +151,7 @@ let (#u ! #id .== #e ! #user_id)) ) :} ->>> Char8.putStrLn $ renderQuery getUsers +>>> printSQL getUsers SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id") Now that we've defined the SQL side of things, we'll need a Haskell type From 48243ab15df6b461421011984d87321504135fa3 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 18:30:25 -0700 Subject: [PATCH 59/92] fix test --- squeal-postgresql/src/Squeal/PostgreSQL.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 07f61416..63a344ef 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -21,6 +21,7 @@ We'll need some imports. >>> import Data.Int (Int32) >>> import Data.Text (Text) >>> import Squeal.PostgreSQL +>>> import Squeal.PostgreSQL.Render We'll use generics to easily convert between Haskell and PostgreSQL values. From 51d36f2cb0eaf188f01dcd4c942c9f3e8e505b54 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 19:46:23 -0700 Subject: [PATCH 60/92] binary docs --- .../src/Squeal/PostgreSQL/Binary.hs | 133 ++++++++++++------ 1 file changed, 90 insertions(+), 43 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 968be60b..f607afe3 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -7,38 +7,71 @@ Stability: experimental Binary encoding and decoding between Haskell and PostgreSQL types. -Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses. +Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses, so you absolutely +do not need to define your own instances to decode retrieved rows into Haskell values or +to encode Haskell values into statement parameters. You only need to derive those type +classes. -Let's see an example of a round trip, inserting a row containing an value of enumerated type -and a value of composite type by encoding Haskell values into Postgres binary format -and then decoding them back into Haskell. +>>> import Data.Int (Int16) +>>> import Data.Text (Text) ->>> import Control.Monad ->>> import Control.Monad.Base ->>> import Data.Text +>>> data Row = Row { col1 :: Int16, col2 :: Text } deriving (Eq, GHC.Generic) +>>> instance Generic Row +>>> instance HasDatatypeInfo Row +>>> import Control.Monad (void) +>>> import Control.Monad.Base (liftBase) >>> import Squeal.PostgreSQL ->>> import qualified Squeal.PostgreSQL as SQL + +>>> :{ +let + query :: Query '[] + '[ 'NotNull 'PGint2, 'NotNull 'PGtext] + '["col1" ::: 'NotNull 'PGint2, "col2" ::: 'NotNull 'PGtext] + query = values_ (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) +:} + +>>> :{ +let + roundtrip :: IO () + roundtrip = void . withConnection "host=localhost port=5432 dbname=exampledb" $ do + result <- runQueryParams query (2 :: Int16, "hi" :: Text) + Just row <- firstRow result + liftBase . print $ row == Row 2 "hi" +:} + +>>> roundtrip +True + +In addition to being able to encode and decode basic Haskell types like `Int16` and `Text`, +Squeal permits you to encode and decode Haskell types which are equivalent to +Postgres enumerated and composite types. + +Enumerated (enum) types are data types that comprise a static, ordered set of values. +They are equivalent to Haskell algebraic data types whose constructors are nullary. +An example of an enum type might be the days of the week, +or a set of status values for a piece of data. >>> data Schwarma = Beef | Lamb | Chicken deriving (Show, GHC.Generic) >>> instance Generic Schwarma >>> instance HasDatatypeInfo Schwarma +A composite type represents the structure of a row or record; +it is essentially just a list of field names and their data types. They are almost +equivalent to Haskell record types. However, because of the potential presence of @NULL@ +all the record fields must be `Maybe`s of basic types. + >>> data Person = Person {name :: Maybe Text, age :: Maybe Int32} deriving (Show, GHC.Generic) >>> instance Generic Person >>> instance HasDatatypeInfo Person ->>> :set -XTypeFamilies -XTypeInType -XUndecidableInstances +We can create the equivalent Postgres types directly from their Haskell types. + >>> :{ -type family Schema :: SchemaType where - Schema = - '[ "schwarma" ::: 'Typedef (EnumWith Schwarma) - , "person" ::: 'Typedef (CompositeWith Person) - , "tab" ::: 'Table ('[] :=> - '[ "col1" ::: 'NoDef :=> 'NotNull (EnumWith Schwarma) - , "col2" ::: 'NoDef :=> 'NotNull (CompositeWith Person) - ]) - ] +type Schema = + '[ "schwarma" ::: 'Typedef (EnumWith Schwarma) + , "person" ::: 'Typedef (CompositeWith Person) + ] :} >>> :{ @@ -46,37 +79,51 @@ let setup :: Definition '[] Schema setup = createTypeEnumWith @Schwarma #schwarma >>> - createTypeCompositeWith @Person #person >>> - createTable #tab ( - notNullable #schwarma `As` #col1 :* - notNullable #person `As` #col2 :* Nil - ) Nil + createTypeCompositeWith @Person #person +:} + +Then we can perform roundtrip queries; + +>>> :{ +let + qry1 :: Query Schema + '[ 'NotNull (EnumWith Schwarma)] + '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] + qry1 = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil) +:} + +>>> :{ +let + qry2 :: Query Schema + '[ 'NotNull (CompositeWith Person)] + '["fromOnly" ::: 'NotNull (CompositeWith Person)] + qry2 = values_ (parameter @1 #person `As` #fromOnly :* Nil) +:} + +And finally drop the types. + +>>> :{ +let teardown :: Definition Schema '[] - teardown = dropTable #tab >>> dropType #schwarma >>> dropType #person - manip :: Manipulation Schema '[ 'NotNull (EnumWith Schwarma), 'NotNull (CompositeWith Person)] '[] - manip = - insertRow_ #tab ( - Set (parameter @1 #schwarma) `As` #col1 :* - Set (parameter @2 #person) `As` #col2 :* Nil) - qry1 :: Query Schema '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] - qry1 = select (#col1 `As` #fromOnly :* Nil) (SQL.from (table #tab)) - qry2 :: Query Schema '[] '["fromOnly" ::: 'NotNull (CompositeWith Person)] - qry2 = select (#col2 `As` #fromOnly :* Nil) (SQL.from (table #tab)) + teardown = dropType #schwarma >>> dropType #person +:} + +Now let's run it. + +>>> :{ +let session = do - manipulateParams manip (Chicken, Person (Just "Faisal") (Just 24)) - result1 <- runQuery qry1 + result1 <- runQueryParams qry1 (Only Chicken) Just (Only schwarma) <- firstRow result1 liftBase $ print (schwarma :: Schwarma) - result2 <- runQuery qry2 + result2 <- runQueryParams qry2 (Only (Person (Just "Faisal") (Just 24))) Just (Only person) <- firstRow result2 liftBase $ print (person :: Person) -:} - ->>> :{ -void . withConnection "host=localhost port=5432 dbname=exampledb" $ - define setup - & pqThen session - & pqThen (define teardown) +in + void . withConnection "host=localhost port=5432 dbname=exampledb" $ + define setup + & pqThen session + & pqThen (define teardown) :} Chicken Person {name = Just "Faisal", age = Just 24} From 922f826b75da06ac7ac92555337b7facf212dcab Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 20:41:19 -0700 Subject: [PATCH 61/92] docs --- squeal-postgresql/src/Squeal/PostgreSQL.hs | 49 +++++++++++----------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 63a344ef..728e33d8 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -36,28 +36,32 @@ type Schema = '[ "users" ::: 'Table ( '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] - ] :=> + , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] + ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) + , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 + , "email" ::: 'NoDef :=> 'Null 'PGtext + ]) ] :} -Notice the use of type operators. `:::` is used -to pair an alias `Symbol` with either a `TableType` or a `ColumnType`. -`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`, +Notice the use of type operators. + +`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`, +a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@ +operator. + +`:=>` is used to pair `TableConstraints` with a `ColumnsType`, yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, -yielding a `ColumnType`. +yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator Next, we'll write `Definition`s to set up and tear down the schema. In -Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable` -command and has two type parameters, corresponding to the schema +Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` +has two type parameters, corresponding to the schema before being run and the schema after. We can compose definitions using `>>>`. Here and in the rest of our commands we make use of overloaded labels to refer to named tables and columns in our schema. @@ -101,12 +105,11 @@ DROP TABLE "emails"; DROP TABLE "users"; Next, we'll write `Manipulation`s to insert data into our two tables. -A `Manipulation` is an `insertRow` (or other inserts), `update` -or `deleteFrom` command and +A `Manipulation` like `insertRow`, `update` or `deleteFrom` has three type parameters, the schema it refers to, a list of parameters it can take as input, and a list of columns it produces as output. When we insert into the users table, we will need a parameter for the @name@ -field but not for the @id@ field. Since it's optional, we can use a default +field but not for the @id@ field. Since it's serial, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into the emails table. Take a careful look at the type and definition of both @@ -144,7 +147,7 @@ need to use an inner join to get the right result. A `Query` is like a let getUsers :: Query Schema '[] '[ "userName" ::: 'NotNull 'PGtext - , "userEmail" ::: 'Null 'PGtext ] + , "userEmail" ::: 'Null 'PGtext ] getUsers = select (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil) ( from (table (#users `As` #u) @@ -195,13 +198,11 @@ let usersResult <- runQuery getUsers usersRows <- getRows usersResult liftBase $ print (usersRows :: [User]) -:} - ->>> :{ -void . withConnection "host=localhost port=5432 dbname=exampledb" $ - define setup - & pqThen session - & pqThen (define teardown) +in + void . withConnection "host=localhost port=5432 dbname=exampledb" $ + define setup + & pqThen session + & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] -} From b1b34c12ec00b8192de05eb509760b80cf54152a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 21:10:17 -0700 Subject: [PATCH 62/92] binary docs --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index f607afe3..3aa60e98 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -5,12 +5,11 @@ Copyright: (c) Eitan Chatav, 2017 Maintainer: eitan@morphism.tech Stability: experimental -Binary encoding and decoding between Haskell and PostgreSQL types. +This module provides binary encoding and decoding between Haskell and PostgreSQL types. Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses, so you absolutely do not need to define your own instances to decode retrieved rows into Haskell values or -to encode Haskell values into statement parameters. You only need to derive those type -classes. +to encode Haskell values into statement parameters. >>> import Data.Int (Int16) >>> import Data.Text (Text) From a1b7db82ddf8b53afcdef1d306ea242e7d19a6d4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 21:16:43 -0700 Subject: [PATCH 63/92] With ~> From --- .../src/Squeal/PostgreSQL/Binary.hs | 26 +++---- .../src/Squeal/PostgreSQL/Definition.hs | 34 +++++----- .../src/Squeal/PostgreSQL/Schema.hs | 67 ++++++++----------- 3 files changed, 59 insertions(+), 68 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 3aa60e98..d11578fc 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -68,8 +68,8 @@ We can create the equivalent Postgres types directly from their Haskell types. >>> :{ type Schema = - '[ "schwarma" ::: 'Typedef (EnumWith Schwarma) - , "person" ::: 'Typedef (CompositeWith Person) + '[ "schwarma" ::: 'Typedef (EnumFrom Schwarma) + , "person" ::: 'Typedef (CompositeFrom Person) ] :} @@ -77,8 +77,8 @@ type Schema = let setup :: Definition '[] Schema setup = - createTypeEnumWith @Schwarma #schwarma >>> - createTypeCompositeWith @Person #person + createTypeEnumFrom @Schwarma #schwarma >>> + createTypeCompositeFrom @Person #person :} Then we can perform roundtrip queries; @@ -86,16 +86,16 @@ Then we can perform roundtrip queries; >>> :{ let qry1 :: Query Schema - '[ 'NotNull (EnumWith Schwarma)] - '["fromOnly" ::: 'NotNull (EnumWith Schwarma)] + '[ 'NotNull (EnumFrom Schwarma)] + '["fromOnly" ::: 'NotNull (EnumFrom Schwarma)] qry1 = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil) :} >>> :{ let qry2 :: Query Schema - '[ 'NotNull (CompositeWith Person)] - '["fromOnly" ::: 'NotNull (CompositeWith Person)] + '[ 'NotNull (CompositeFrom Person)] + '["fromOnly" ::: 'NotNull (CompositeFrom Person)] qry2 = values_ (parameter @1 #person `As` #fromOnly :* Nil) :} @@ -241,7 +241,7 @@ instance (HasOid pg, ToParam x pg) instance ( IsEnumType x , HasDatatypeInfo x - , LabelsWith x ~ labels + , LabelsFrom x ~ labels ) => ToParam x ('PGenum labels) where toParam = let @@ -261,7 +261,7 @@ instance , MapMaybes xs , IsProductType x (Maybes xs) , AllZip ToAliasedParam xs fields - , FieldNamesWith x ~ AliasesOf fields + , FieldNamesFrom x ~ AliasesOf fields , All HasAliasedOid fields ) => ToParam x ('PGcomposite fields) where toParam = @@ -397,7 +397,7 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where instance ( IsEnumType y , HasDatatypeInfo y - , LabelsWith y ~ labels + , LabelsFrom y ~ labels ) => FromValue ('PGenum labels) y where fromValue _ = let @@ -422,7 +422,7 @@ instance , MapMaybes ys , IsProductType y (Maybes ys) , AllZip FromAliasedValue fields ys - , FieldNamesWith y ~ AliasesOf fields + , FieldNamesFrom y ~ AliasesOf fields ) => FromValue ('PGcomposite fields) y where fromValue = let @@ -515,7 +515,7 @@ instance ( SListI results , IsProductType y ys , AllZip FromColumnValue results ys - , FieldNamesWith y ~ AliasesOf results + , FieldNamesFrom y ~ AliasesOf results ) => FromRow results y where fromRow = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 10a40fcc..8f4459e5 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -68,9 +68,9 @@ module Squeal.PostgreSQL.Definition , dropView -- * Types , createTypeEnum - , createTypeEnumWith + , createTypeEnumFrom , createTypeComposite - , createTypeCompositeWith + , createTypeCompositeFrom , dropType -- * Columns , ColumnTypeExpression (..) @@ -835,19 +835,19 @@ createTypeEnum enum labels = UnsafeDefinition $ -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> printSQL $ createTypeEnumWith @Schwarma #schwarma +-- >>> printSQL $ createTypeEnumFrom @Schwarma #schwarma -- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); -createTypeEnumWith +createTypeEnumFrom :: forall hask enum schema. ( SOP.Generic hask - , SOP.All KnownSymbol (LabelsWith hask) + , SOP.All KnownSymbol (LabelsFrom hask) , KnownSymbol enum ) => Alias enum -- ^ name of the user defined enumerated type - -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema) -createTypeEnumWith enum = createTypeEnum enum - (SOP.hpure label :: NP PGlabel (LabelsWith hask)) + -> Definition schema (Create enum ('Typedef (EnumFrom hask)) schema) +createTypeEnumFrom enum = createTypeEnum enum + (SOP.hpure label :: NP PGlabel (LabelsFrom hask)) -- | `createTypeComposite` creates a composite type. The composite type is -- specified by a list of attribute names and data types. @@ -874,28 +874,28 @@ createTypeComposite ty fields = UnsafeDefinition $ -- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic -- >>> instance SOP.Generic Complex -- >>> instance SOP.HasDatatypeInfo Complex --- >>> printSQL $ createTypeCompositeWith @Complex #complex +-- >>> printSQL $ createTypeCompositeFrom @Complex #complex -- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); -createTypeCompositeWith +createTypeCompositeFrom :: forall hask ty schema. - ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask) - , SOP.All (PGTyped schema) (FieldTypesWith hask) + ( ZipAliased (FieldNamesFrom hask) (FieldTypesFrom hask) + , SOP.All (PGTyped schema) (FieldTypesFrom hask) , KnownSymbol ty ) => Alias ty -- ^ name of the user defined composite type - -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema) -createTypeCompositeWith ty = createTypeComposite ty $ zipAs - (SOP.hpure Alias :: NP Alias (FieldNamesWith hask)) + -> Definition schema (Create ty ( 'Typedef (CompositeFrom hask)) schema) +createTypeCompositeFrom ty = createTypeComposite ty $ zipAs + (SOP.hpure Alias :: NP Alias (FieldNamesFrom hask)) (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype - :: NP (TypeExpression schema) (FieldTypesWith hask)) + :: NP (TypeExpression schema) (FieldTypesFrom hask)) -- | Drop a type. -- -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[]) +-- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] '[]) -- DROP TYPE "schwarma"; dropType :: Has tydef schema ('Typedef ty) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index b9781285..b4a0e58a 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -100,15 +100,13 @@ module Squeal.PostgreSQL.Schema , PGlabel (..) , renderLabel , renderLabels - , LabelOf - , LabelsOf -- * Embedding , PG - , EnumWith - , LabelsWith - , CompositeWith - , FieldNamesWith - , FieldTypesWith + , EnumFrom + , LabelsFrom + , CompositeFrom + , FieldNamesFrom + , FieldTypesFrom , ConstructorsOf , ConstructorNameOf , ConstructorNamesOf @@ -682,13 +680,6 @@ renderLabels :: All KnownSymbol labels => NP PGlabel labels -> [ByteString] renderLabels = hcollapse . hcmap (Proxy @KnownSymbol) (K . renderLabel) --- | Gets the name of a type constructor -type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where - LabelOf ('Type.Constructor name) = name --- | Gets the names of a list of type constructors -type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where - LabelsOf '[] = '[] - LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss -- | The `PG` type family embeds a subset of Haskell types -- as Postgres basic types. @@ -724,32 +715,32 @@ type family PG (hask :: Type) :: PGType where PG ty = TypeError ('Text "There is no Postgres basic type for " ':<>: 'ShowType ty) --- | The `EnumWith` type family embeds Haskell enum types, ADTs with +-- | The `EnumFrom` type family embeds Haskell enum types, ADTs with -- nullary constructors, as Postgres enum types -- -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance Generic Schwarma -- >>> instance HasDatatypeInfo Schwarma --- >>> :kind! EnumWith Schwarma --- EnumWith Schwarma :: PGType +-- >>> :kind! EnumFrom Schwarma +-- EnumFrom Schwarma :: PGType -- = 'PGenum '["Beef", "Lamb", "Chicken"] -type family EnumWith (hask :: Type) :: PGType where - EnumWith hask = 'PGenum (LabelsWith hask) +type family EnumFrom (hask :: Type) :: PGType where + EnumFrom hask = 'PGenum (LabelsFrom hask) --- | The `LabelsWith` type family calculates the constructors of a +-- | The `LabelsFrom` type family calculates the constructors of a -- Haskell enum type. -- -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance Generic Schwarma -- >>> instance HasDatatypeInfo Schwarma --- >>> :kind! LabelsWith Schwarma --- LabelsWith Schwarma :: [Type.ConstructorName] +-- >>> :kind! LabelsFrom Schwarma +-- LabelsFrom Schwarma :: [Type.ConstructorName] -- = '["Beef", "Lamb", "Chicken"] -type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where - LabelsWith hask = +type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where + LabelsFrom hask = ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask)) --- | The `CompositeWith` type family embeds Haskell record types as +-- | The `CompositeFrom` type family embeds Haskell record types as -- Postgres composite types, as long as the record fields -- are `Maybe`s of Haskell types that can be embedded as basic types -- with the `PG` type family. @@ -757,30 +748,30 @@ type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where -- >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic -- >>> instance Generic Row -- >>> instance HasDatatypeInfo Row --- >>> :kind! CompositeWith Row --- CompositeWith Row :: PGType +-- >>> :kind! CompositeFrom Row +-- CompositeFrom Row :: PGType -- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)] -type family CompositeWith (hask :: Type) :: PGType where - CompositeWith hask = - 'PGcomposite (ZipAs (FieldNamesWith hask) (FieldTypesWith hask)) +type family CompositeFrom (hask :: Type) :: PGType where + CompositeFrom hask = + 'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask)) -- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic -- >>> instance Generic Row -- >>> instance HasDatatypeInfo Row --- >>> :kind! FieldNamesWith Row --- FieldNamesWith Row :: [Type.FieldName] +-- >>> :kind! FieldNamesFrom Row +-- FieldNamesFrom Row :: [Type.FieldName] -- = '["a", "b"] -type family FieldNamesWith (hask :: Type) :: [Type.FieldName] where - FieldNamesWith hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask)) +type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where + FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask)) -- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic -- >>> instance Generic Row -- >>> instance HasDatatypeInfo Row --- >>> :kind! FieldTypesWith Row --- FieldTypesWith Row :: [PGType] +-- >>> :kind! FieldTypesFrom Row +-- FieldTypesFrom Row :: [PGType] -- = '['PGint2, 'PGtimestamp] -type family FieldTypesWith (hask :: Type) :: [PGType] where - FieldTypesWith hask = FieldTypesOf (RecordCodeOf hask (Code hask)) +type family FieldTypesFrom (hask :: Type) :: [PGType] where + FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask)) -- | Calculates constructors of a datatype. type family ConstructorsOf (datatype :: Type.DatatypeInfo) From 27f756b545c466d1713382244cbb95ebf638a105 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 21:52:04 -0700 Subject: [PATCH 64/92] docs --- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 12 ++++++------ .../src/Squeal/PostgreSQL/Expression.hs | 13 ++++++++++++- 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index d11578fc..570cb687 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -85,18 +85,18 @@ Then we can perform roundtrip queries; >>> :{ let - qry1 :: Query Schema + querySchwarma :: Query Schema '[ 'NotNull (EnumFrom Schwarma)] '["fromOnly" ::: 'NotNull (EnumFrom Schwarma)] - qry1 = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil) + querySchwarma = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil) :} >>> :{ let - qry2 :: Query Schema + queryPerson :: Query Schema '[ 'NotNull (CompositeFrom Person)] '["fromOnly" ::: 'NotNull (CompositeFrom Person)] - qry2 = values_ (parameter @1 #person `As` #fromOnly :* Nil) + queryPerson = values_ (parameter @1 #person `As` #fromOnly :* Nil) :} And finally drop the types. @@ -112,10 +112,10 @@ Now let's run it. >>> :{ let session = do - result1 <- runQueryParams qry1 (Only Chicken) + result1 <- runQueryParams querySchwarma (Only Chicken) Just (Only schwarma) <- firstRow result1 liftBase $ print (schwarma :: Schwarma) - result2 <- runQueryParams qry2 (Only (Person (Just "Faisal") (Just 24))) + result2 <- runQueryParams queryPerson (Only (Person (Just "Faisal") (Just 24))) Just (Only person) <- firstRow result2 liftBase $ print (person :: Person) in diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs index c0dc86df..6d193e34 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs @@ -189,6 +189,11 @@ class KnownNat n => HasParameter (params :: [NullityType]) (ty :: NullityType) | n params -> ty where + -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. + -- + -- >>> let expr = parameter @1 int4 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4) + -- >>> printSQL expr + -- ($1 :: int4) parameter :: TypeExpression schema (PGTypeOf ty) -> Expression schema relations grouping params ty @@ -199,10 +204,16 @@ instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1 instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty) => HasParameter n schema (ty' : params) ty +-- | `param` takes a `Nat` using type application and for basic types, +-- infers a `TypeExpression`. +-- +-- >>> let expr = param @1 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4) +-- >>> printSQL expr +-- ($1 :: int4) param :: forall n schema params relations grouping ty . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty) - => Expression schema relations grouping params ty + => Expression schema relations grouping params ty -- ^ param param = parameter @n pgtype instance (HasUnique relation relations columns, Has column columns ty) From 2eb541d0aff9945e6f722b0a22e1cc358ea9b979 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 21 Jun 2018 23:55:26 -0700 Subject: [PATCH 65/92] haddocks --- .../src/Squeal/PostgreSQL/Schema.hs | 27 ++++++++++--------- 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index b4a0e58a..28cc1c6e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -5,7 +5,10 @@ Copyright: (c) Eitan Chatav, 2017 Maintainer: eitan@morphism.tech Stability: experimental -A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. +This module provides a type-level DSL for kinds of Postgres types, +tables, schema, constraints, aliases, enumerated labels, and groupings. +It also defines useful type families to operate on these. Finally, +it defines an embedding of Haskell types into Postgres types. -} {-# LANGUAGE @@ -35,6 +38,7 @@ module Squeal.PostgreSQL.Schema , HasOid (..) , NullityType (..) , ColumnType + -- * Tables , ColumnsType , RelationType , NilRelation @@ -43,9 +47,6 @@ module Squeal.PostgreSQL.Schema -- * Schema , SchemumType (..) , SchemaType - -- * Grouping - , Grouping (..) - , GroupedBy -- * Constraints , (:=>) , ColumnConstraint (..) @@ -67,6 +68,14 @@ module Squeal.PostgreSQL.Schema , HasAll , IsLabel (..) , IsQualified (..) + -- * Enumerated Labels + , IsPGlabel (..) + , PGlabel (..) + , renderLabel + , renderLabels + -- * Grouping + , Grouping (..) + , GroupedBy -- * Type Families , Join , With @@ -92,14 +101,6 @@ module Squeal.PostgreSQL.Schema , TableToRelation , ConstraintInvolves , DropIfConstraintsInvolve - -- * Generics - , MapMaybes (..) - , Nulls - -- * Enum Labels - , IsPGlabel (..) - , PGlabel (..) - , renderLabel - , renderLabels -- * Embedding , PG , EnumFrom @@ -116,6 +117,8 @@ module Squeal.PostgreSQL.Schema , FieldTypeOf , FieldTypesOf , RecordCodeOf + , MapMaybes (..) + , Nulls ) where import Control.DeepSeq From 0fcdcd0c6a293d10ac7e89049bcefdede313356e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 22 Jun 2018 19:32:09 -0700 Subject: [PATCH 66/92] docs --- squeal-postgresql/src/Squeal/PostgreSQL.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs | 2 +- squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs | 11 ++++++----- .../src/Squeal/PostgreSQL/Manipulation.hs | 8 ++++---- squeal-postgresql/src/Squeal/PostgreSQL/Render.hs | 2 ++ squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs | 5 +---- 6 files changed, 15 insertions(+), 15 deletions(-) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs index 728e33d8..7a3d98c2 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL.hs @@ -83,7 +83,7 @@ let OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) :} -We can easily see the generated SQL is unsuprising looking. +We can easily see the generated SQL is unsurprising looking. >>> printSQL setup CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs index 570cb687..c6fb1b8e 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs @@ -314,7 +314,7 @@ instance ToParam x ty => ToAliasedParam x (alias ::: ty) where Just x -> K . Just . unK $ toParam @x @ty x -- | A `ToColumnParam` constraint lifts the `ToParam` encoding --- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should +-- of a `Type` to a `NullityType`, encoding `Maybe`s to `Null`s. You should -- not define instances of `ToColumnParam`, just use the provided instances. class ToColumnParam (x :: Type) (ty :: NullityType) where -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0 diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs index 8f4459e5..5393cda7 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs @@ -151,7 +151,8 @@ createTable tab columns constraints = UnsafeDefinition $ {-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. -`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`. +`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in +the `Category` of `Definition`s. >>> :set -XOverloadedLabels -XTypeApplications >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4] @@ -789,7 +790,7 @@ alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty -- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; createView :: KnownSymbol view - => Alias view -- ^ the name of the table to add + => Alias view -- ^ the name of the view to add -> Query schema '[] relation -- ^ query -> Definition schema (Create view ('View relation) schema) @@ -932,19 +933,19 @@ default_ x ty = UnsafeColumnTypeExpression $ renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x -- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `'PGint2` +-- unique identifier columns with type `PGint2` serial2, smallserial :: ColumnTypeExpression schema ('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` +-- unique identifier columns with type `PGint4` serial4, serial :: ColumnTypeExpression schema ('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` +-- unique identifier columns with type `PGint8` serial8, bigserial :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8) serial8 = UnsafeColumnTypeExpression "serial8" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs index f758fdcf..b83f8a56 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs @@ -302,11 +302,11 @@ insertQuery_ insertQuery_ tab query = insertQuery tab query OnConflictDoRaise (Returning Nil) --- | `ColumnValue`s are values to insert or update in a row +-- | `ColumnValue`s are values to insert or update in a row. -- `Same` updates with the same value. --- `Default` inserts or updates with the @DEFAULT@ value --- `Set` a value to be an `Expression`, relative to the given --- row for an update, and closed for an insert. +-- `Default` inserts or updates with the @DEFAULT@ value. +-- `Set` sets a value to be an `Expression`, which can refer to +-- existing value in the row for an update. data ColumnValue (schema :: SchemaType) (columns :: RelationType) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs index eae11641..4b6beacb 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs @@ -83,8 +83,10 @@ renderCommaSeparatedMaybe render renderNat :: KnownNat n => proxy n -> ByteString renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n))) +-- | A class for rendering SQL class RenderSQL sql where renderSQL :: sql -> ByteString +-- | Print SQL. printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io () printSQL = liftBase . Char8.putStrLn . renderSQL diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs index 28cc1c6e..6e04ffad 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs @@ -226,10 +226,7 @@ type (:=>) constraint ty = '(constraint,ty) infixr 7 :=> -- | The alias operator `:::` is like a promoted version of `As`, --- a type level pair between --- an alias and some type, like a column alias and either a `ColumnType` or --- `NullityType` or a table alias and either a `TableType` or a `RelationType` --- or a constraint alias and a `TableConstraint`. +-- a type level pair between an alias and some type. type (:::) (alias :: Symbol) ty = '(alias,ty) infixr 6 ::: From 125e13a8ac0ea46d69161927db4e75744359319f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 22 Jun 2018 19:36:13 -0700 Subject: [PATCH 67/92] readme --- README.md | 154 +++++++++++++++++++++++++++++------------------------- 1 file changed, 83 insertions(+), 71 deletions(-) diff --git a/README.md b/README.md index 41088461..461f8298 100644 --- a/README.md +++ b/README.md @@ -44,6 +44,8 @@ composable and cover a large portion of SQL. * linear, invertible migrations * connection pools * transactions +* views +* composite and enumerated types ## installation @@ -62,118 +64,125 @@ Let's see an example! First, we need some language extensions because Squeal uses modern GHC features. -```haskell +```Haskell >>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators ``` We'll need some imports. -```haskell +```Haskell >>> import Control.Monad (void) >>> import Control.Monad.Base (liftBase) >>> import Data.Int (Int32) >>> import Data.Text (Text) >>> import Squeal.PostgreSQL +>>> import Squeal.PostgreSQL.Render ``` We'll use generics to easily convert between Haskell and PostgreSQL values. -```haskell +```Haskell >>> import qualified Generics.SOP as SOP >>> import qualified GHC.Generics as GHC ``` The first step is to define the schema of our database. This is where -we use `DataKinds` and `TypeOperators`. +we use @DataKinds@ and @TypeOperators@. -```haskell +```Haskell >>> :{ type Schema = - '[ "users" ::: - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] - , "emails" ::: - '[ "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 - ] - ] + '[ "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 + ]) + ] :} ``` -Notice the use of type operators. `:::` is used -to pair an alias `Symbol` with either a `TableType` or a `ColumnType`. -`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`, +Notice the use of type operators. + +`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`, +a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@ +operator. + +`:=>` is used to pair `TableConstraints` with a `ColumnsType`, yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, -yielding a `ColumnType`. +yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator Next, we'll write `Definition`s to set up and tear down the schema. In -Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable` -command and has two type parameters, corresponding to the schema -before being run and the schema after. We can compose definitions using -`>>>`. Here and in the rest of our commands we make use of overloaded +Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` +has two type parameters, corresponding to the schema +before being run and the schema after. We can compose definitions using `>>>`. +Here and in the rest of our commands we make use of overloaded labels to refer to named tables and columns in our schema. -```haskell +```Haskell >>> :{ let setup :: Definition '[] Schema setup = - createTable #users - ( serial `As` #id :* - (text & notNullable) `As` #name :* Nil ) - ( primaryKey #id `As` #pk_users :* Nil ) >>> - createTable #emails - ( serial `As` #id :* - (int & notNullable) `As` #user_id :* - (text & nullable) `As` #email :* Nil ) - ( primaryKey #id `As` #pk_emails :* - foreignKey #user_id #users #id - OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) + createTable #users + ( serial `As` #id :* + (text & notNullable) `As` #name :* Nil ) + ( primaryKey #id `As` #pk_users :* Nil ) >>> + createTable #emails + ( serial `As` #id :* + (int & notNullable) `As` #user_id :* + (text & nullable) `As` #email :* Nil ) + ( primaryKey #id `As` #pk_emails :* + foreignKey #user_id #users #id + OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil ) :} ``` -We can easily see the generated SQL is unsuprising looking. +We can easily see the generated SQL is unsurprising looking. -```haskell ->>> renderDefinition 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, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE CASCADE ON UPDATE CASCADE);" +```Haskell +>>> 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); ``` -Notice that `setup` starts with an empty schema `'[]` and produces `Schema`. +Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@. In our `createTable` commands we included `TableConstraint`s to define -primary and foreign keys, making them somewhat complex. Our tear down +primary and foreign keys, making them somewhat complex. Our @teardown@ `Definition` is simpler. -```haskell +```Haskell >>> :{ let teardown :: Definition Schema '[] teardown = dropTable #emails >>> dropTable #users :} ->>> renderDefinition teardown -"DROP TABLE emails; DROP TABLE users;" + +>>> printSQL teardown +DROP TABLE "emails"; +DROP TABLE "users"; ``` Next, we'll write `Manipulation`s to insert data into our two tables. -A `Manipulation` is an `insertRow` (or other inserts), `update` -or `deleteFrom` command and +A `Manipulation` like `insertRow`, `update` or `deleteFrom` has three type parameters, the schema it refers to, a list of parameters it can take as input, and a list of columns it produces as output. When -we insert into the users table, we will need a parameter for the `name` -field but not for the `id` field. Since it's optional, we can use a default +we insert into the users table, we will need a parameter for the @name@ +field but not for the @id@ field. Since it's serial, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into the emails table. Take a careful look at the type and definition of both of our inserts. -```haskell +```Haskell >>> :{ let insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ] @@ -181,6 +190,7 @@ let (Default `As` #id :* Set (param @1) `As` #name :* Nil) OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil)) :} + >>> :{ let insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[] @@ -190,10 +200,11 @@ let Set (param @2) `As` #email :* Nil ) OnConflictDoNothing (Returning Nil) :} ->>> renderManipulation insertUser -"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING id AS fromOnly;" ->>> renderManipulation insertEmail -"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING;" + +>>> printSQL insertUser +INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly" +>>> printSQL insertEmail +INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING ``` Next we write a `Query` to retrieve users from the database. We're not @@ -201,7 +212,7 @@ interested in the ids here, just the usernames and email addresses. We need to use an inner join to get the right result. A `Query` is like a `Manipulation` with the same kind of type parameters. -```haskell +```Haskell >>> :{ let getUsers :: Query Schema '[] @@ -213,17 +224,18 @@ let & innerJoin (table (#emails `As` #e)) (#u ! #id .== #e ! #user_id)) ) :} ->>> renderQuery getUsers -"SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails AS e ON (u.id = e.user_id)" + +>>> printSQL getUsers +SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id") ``` Now that we've defined the SQL side of things, we'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and `Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows -we receive when we run `getUsers`. Notice that the record fields of the -`User` type match the column names of `getUsers`. +we receive when we run @getUsers@. Notice that the record fields of the +@User@ type match the column names of @getUsers@. -```haskell +```Haskell >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) >>> instance SOP.Generic User >>> instance SOP.HasDatatypeInfo User @@ -231,7 +243,7 @@ we receive when we run `getUsers`. Notice that the record fields of the Let's also create some users to add to the database. -```haskell +```Haskell >>> :{ let users :: [User] @@ -251,7 +263,7 @@ the changing schema information through by using the indexed `PQ` monad transformer and when the schema doesn't change we can use `Monad` and `MonadPQ` functionality. -```haskell +```Haskell >>> :{ let session :: PQ Schema Schema IO () @@ -262,12 +274,12 @@ let usersResult <- runQuery getUsers usersRows <- getRows usersResult liftBase $ print (usersRows :: [User]) -:} ->>> :{ -void . withConnection "host=localhost port=5432 dbname=exampledb" $ - define setup - & pqThen session - & pqThen (define teardown) +in + void . withConnection "host=localhost port=5432 dbname=exampledb" $ + define setup + & pqThen session + & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] +-} ``` From bfe3e290cfe190841cf7c8ca44255fb1aa420e1a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 22 Jun 2018 19:40:08 -0700 Subject: [PATCH 68/92] readme --- README.md | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 461f8298..4533251f 100644 --- a/README.md +++ b/README.md @@ -88,7 +88,7 @@ We'll use generics to easily convert between Haskell and PostgreSQL values. ``` The first step is to define the schema of our database. This is where -we use @DataKinds@ and @TypeOperators@. +we use `DataKinds` and `TypeOperators`. ```Haskell >>> :{ @@ -113,12 +113,12 @@ type Schema = Notice the use of type operators. `:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`, -a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@ +a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::` operator. `:=>` is used to pair `TableConstraints` with a `ColumnsType`, yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`, -yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator +yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator Next, we'll write `Definition`s to set up and tear down the schema. In Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` @@ -154,9 +154,9 @@ CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" P 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); ``` -Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@. +Notice that `setup` starts with an empty schema `'[]` and produces `Schema`. In our `createTable` commands we included `TableConstraint`s to define -primary and foreign keys, making them somewhat complex. Our @teardown@ +primary and foreign keys, making them somewhat complex. Our `teardown` `Definition` is simpler. ```Haskell @@ -175,8 +175,8 @@ Next, we'll write `Manipulation`s to insert data into our two tables. A `Manipulation` like `insertRow`, `update` or `deleteFrom` has three type parameters, the schema it refers to, a list of parameters it can take as input, and a list of columns it produces as output. When -we insert into the users table, we will need a parameter for the @name@ -field but not for the @id@ field. Since it's serial, we can use a default +we insert into the users table, we will need a parameter for the `name` +field but not for the `id` field. Since it's serial, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into the emails table. Take a careful look at the type and definition of both @@ -232,8 +232,8 @@ SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" Now that we've defined the SQL side of things, we'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and `Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows -we receive when we run @getUsers@. Notice that the record fields of the -@User@ type match the column names of @getUsers@. +we receive when we run `getUsers`. Notice that the record fields of the +`User` type match the column names of `getUsers`. ```Haskell >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic) From 442d285dd479ad759004ad06e5fa4f4ca03f4b69 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 22 Jun 2018 19:40:43 -0700 Subject: [PATCH 69/92] fix --- README.md | 1 - 1 file changed, 1 deletion(-) diff --git a/README.md b/README.md index 4533251f..e4586c72 100644 --- a/README.md +++ b/README.md @@ -281,5 +281,4 @@ in & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] --} ``` From 55374089f00e3b39f2f53dbc5436714982382248 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 22 Jun 2018 20:02:09 -0700 Subject: [PATCH 70/92] cabal & stack yaml --- squeal-postgresql/squeal-postgresql.cabal | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index 6d03a9e2..d960b9b8 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -39,8 +39,8 @@ library aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 , binary-parser >= 0.5.5 - , bytestring-strict-builder >= 0.4.5 , bytestring >= 0.10.8.2 + , bytestring-strict-builder >= 0.4.5 , deepseq >= 1.4.3.0 , generics-sop >= 0.3.2.0 , lifted-base >= 0.2.3.12 diff --git a/stack.yaml b/stack.yaml index 192e3d42..782df632 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-11.1 +resolver: lts-11.14 packages: - squeal-postgresql From e1850b78bacde8db15f4b1312c4f042f69c9b38f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 22 Jun 2018 20:08:39 -0700 Subject: [PATCH 71/92] release notes --- RELEASE NOTES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index f449fe24..9b7868d3 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -1,5 +1,12 @@ ## RELEASE NOTES +### Version 0.3.0.0 - June 23, 2018 + +**Changes** +- **Views** - Create, drop and query views +- **Enums, Composites** - Create, drop and marshal enumerated and composite types +- **Bugfixes** + ### Version 0.2.1 - April 7, 2018 This minor update fixes an issue where alias identifiers could conflict with From 82bd2b55c88c3c808611f053c59015c6a1050e50 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 08:28:20 -0700 Subject: [PATCH 72/92] try to fix circle --- .circleci/config.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 7e2752bb..a6cfb788 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -12,8 +12,8 @@ jobs: keys: - dependency-cache - run: apt-get update && apt-get install -y libpq-dev xz-utils make - - run: stack upgrade && stack update - - run: stack build + - run: stack setup && stack upgrade && stack update + - run: stack build --resolver ghc-8.4.3 - run: stack test - run: stack haddock - save_cache: From 83a1c9e081b519de4f001b3c41bb1867012be441 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 08:31:19 -0700 Subject: [PATCH 73/92] cabal and circle --- .circleci/config.yml | 2 +- squeal-postgresql/squeal-postgresql.cabal | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index a6cfb788..deea1fc5 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -13,7 +13,7 @@ jobs: - dependency-cache - run: apt-get update && apt-get install -y libpq-dev xz-utils make - run: stack setup && stack upgrade && stack update - - run: stack build --resolver ghc-8.4.3 + - run: stack build - run: stack test - run: stack haddock - save_cache: diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index d960b9b8..2a7898e7 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -34,7 +34,7 @@ library Squeal.PostgreSQL.Schema Squeal.PostgreSQL.Transaction default-language: Haskell2010 - ghc-options: -Wall -fprint-explicit-kinds + ghc-options: -Wall -Werror -fprint-explicit-kinds build-depends: aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 @@ -63,7 +63,7 @@ test-suite squeal-postgresql-doctest default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - ghc-options: -Wall + ghc-options: -Wall -Werror main-is: DocTest.hs build-depends: base >= 4.10.0.0 @@ -72,7 +72,7 @@ test-suite squeal-postgresql-doctest executable squeal-postgresql-example default-language: Haskell2010 hs-source-dirs: exe - ghc-options: -Wall + ghc-options: -Wall -Werror main-is: Example.hs build-depends: base >= 4.10.0.0 && < 5.0 From c79b77da6ffaa52d216b14ab4f263f4854de8709 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 08:54:33 -0700 Subject: [PATCH 74/92] circle & stack --- .circleci/config.yml | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index deea1fc5..3379c2b1 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -2,7 +2,7 @@ version: 2 jobs: build: docker: - - image: haskell:latest + - image: haskell:8.2.2 - image: circleci/postgres:latest environment: POSTGRES_DB: exampledb diff --git a/stack.yaml b/stack.yaml index 782df632..a78c9ce1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-11.14 +resolver: lts-11.15 packages: - squeal-postgresql From 89173fa8dd3603b306da28412cac0aae12f07233 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 09:45:08 -0700 Subject: [PATCH 75/92] release notes views release notes views --- RELEASE NOTES.md | 90 +++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 86 insertions(+), 4 deletions(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 9b7868d3..782b20c4 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -2,10 +2,92 @@ ### Version 0.3.0.0 - June 23, 2018 -**Changes** -- **Views** - Create, drop and query views -- **Enums, Composites** - Create, drop and marshal enumerated and composite types -- **Bugfixes** +Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal. +To support these features, a new kind `SchemumType` was added. + +```Haskell +data SchemumType + = Table TableType + | View RelationType + | Typedef PGType +``` + +As a consequence, you will have to update your schema definitions like so: + +```Haskell +-- Squeal 0.2 +type Schema = + '[ "users" ::: + '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ] + ] + +-- Squeal 0.3 +type Schema = + '[ "users" ::: 'Table ( + '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> + '[ "id" ::: 'Def :=> 'NotNull 'PGint4 + , "name" ::: 'NoDef :=> 'NotNull 'PGtext + ]) + ] +``` + +**Views** + +You can now create, drop, and query views. + +```Haskell +>>> :{ +type ABC = + ('[] :: TableConstraints) :=> + '[ "a" ::: 'NoDef :=> 'Null 'PGint4 + , "b" ::: 'NoDef :=> 'Null 'PGint4 + , "c" ::: 'NoDef :=> 'Null 'PGint4 + ] +type BC = + '[ "b" ::: 'Null 'PGint4 + , "c" ::: 'Null 'PGint4 + ] +:} + +>>> :{ +let + definition :: Definition + '[ "abc" ::: 'Table ABC ] + '[ "abc" ::: 'Table ABC + , "bc" ::: 'View BC + ] + definition = + createView #bc (select (#b :* #c :* Nil) (from (table #abc))) +in printSQL definition +:} +CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; + +>>> :{ +let + definition :: Definition + '[ "abc" ::: 'Table ABC + , "bc" ::: 'View BC + ] + '[ "abc" ::: 'Table ABC ] + definition = dropView #bc +in printSQL definition +:} +DROP VIEW "bc"; + +>>> :{ +let + query :: Query + '[ "abc" ::: 'Table ABC + , "bc" ::: 'View BC + ] '[] BC + query = selectStar (from (view #bc)) +in printSQL query +:} +SELECT * FROM "bc" AS "bc" +``` ### Version 0.2.1 - April 7, 2018 From aa91c353c6e66426bc349bc37d084fc0af27b153 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 10:00:42 -0700 Subject: [PATCH 76/92] Update RELEASE NOTES.md enum type notes --- RELEASE NOTES.md | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 782b20c4..17067a82 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -1,6 +1,6 @@ ## RELEASE NOTES -### Version 0.3.0.0 - June 23, 2018 +### Version 0.3 - June 23, 2018 Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal. To support these features, a new kind `SchemumType` was added. @@ -89,6 +89,30 @@ in printSQL query SELECT * FROM "bc" AS "bc" ``` +**Enumerated Types** + +PostgreSQL has a powerful type system. It even allows for user defined types. +For instance, you can define enumerated types which are data types that comprise +a static, ordered set of values. An example of an enum type might be the days of the week, +or a set of status values for a piece of data. + +Enumerated types are created using the `createTypeEnum` command, for example + +```Haskell +>>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); +``` + +Enumerated types can also be generated from a Haskell type, for example + +```Haskell +>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic +>>> instance SOP.Generic Schwarma +>>> instance SOP.HasDatatypeInfo Schwarma +>>> printSQL $ createTypeEnumFrom @Schwarma #schwarma +CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); +``` + ### Version 0.2.1 - April 7, 2018 This minor update fixes an issue where alias identifiers could conflict with From d3b55de9735178bc2e16e488533124e166ec37e1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 10:28:37 -0700 Subject: [PATCH 77/92] Update RELEASE NOTES.md one line --- RELEASE NOTES.md | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 17067a82..efd9e87a 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -54,11 +54,7 @@ type BC = >>> :{ let - definition :: Definition - '[ "abc" ::: 'Table ABC ] - '[ "abc" ::: 'Table ABC - , "bc" ::: 'View BC - ] + definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC] definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc))) in printSQL definition @@ -67,11 +63,7 @@ CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; >>> :{ let - definition :: Definition - '[ "abc" ::: 'Table ABC - , "bc" ::: 'View BC - ] - '[ "abc" ::: 'Table ABC ] + definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC] definition = dropView #bc in printSQL definition :} @@ -79,10 +71,7 @@ DROP VIEW "bc"; >>> :{ let - query :: Query - '[ "abc" ::: 'Table ABC - , "bc" ::: 'View BC - ] '[] BC + query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC query = selectStar (from (view #bc)) in printSQL query :} From 0d779f5dac3e7c0de0337cfbb52030172e6a80ca Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 10:42:26 -0700 Subject: [PATCH 78/92] Update RELEASE NOTES.md more enum notes --- RELEASE NOTES.md | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index efd9e87a..8b402d54 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -55,8 +55,7 @@ type BC = >>> :{ let definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC] - definition = - createView #bc (select (#b :* #c :* Nil) (from (table #abc))) + definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc))) in printSQL definition :} CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; @@ -82,26 +81,52 @@ SELECT * FROM "bc" AS "bc" PostgreSQL has a powerful type system. It even allows for user defined types. For instance, you can define enumerated types which are data types that comprise -a static, ordered set of values. An example of an enum type might be the days of the week, +a static, ordered set of values. They are equivalent to Haskell algebraic data +types whose constructors are nullary. An example of an enum type might be the days of the week, or a set of status values for a piece of data. Enumerated types are created using the `createTypeEnum` command, for example ```Haskell ->>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +>>> :{ +let + definition :: Definition '[] '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] + definition = createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) +:} +>>> printSQL definition CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); ``` -Enumerated types can also be generated from a Haskell type, for example +Enumerated types can also be generated from a Haskell algbraic data type with nullary constructors, for example ```Haskell >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic >>> instance SOP.Generic Schwarma >>> instance SOP.HasDatatypeInfo Schwarma ->>> printSQL $ createTypeEnumFrom @Schwarma #schwarma +>>> :{ +let + definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] + definition = createTypeEnumFrom @Schwarma #schwarma +:} +>>> printSQL definition CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); ``` +You can express values of an enum type using `label`, which is an overloaded method +of the `IsPGlabel` typeclass. + +>>> :{ +let + expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma)) + expression = label @"Chicken" +in printSQL expression +:} +'Chicken' + +**Composite Types** + + + ### Version 0.2.1 - April 7, 2018 This minor update fixes an issue where alias identifiers could conflict with From e98a73f2b93947a1c6b333653ee657c256b9a233 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 10:44:08 -0700 Subject: [PATCH 79/92] Update RELEASE NOTES.md code block --- RELEASE NOTES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 8b402d54..6b8729f2 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -115,6 +115,7 @@ CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); You can express values of an enum type using `label`, which is an overloaded method of the `IsPGlabel` typeclass. +```Haskell >>> :{ let expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma)) @@ -122,6 +123,7 @@ let in printSQL expression :} 'Chicken' +``` **Composite Types** From dcb532d5023c75cb9c9a387bdce0dad2a3914441 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 10:50:26 -0700 Subject: [PATCH 80/92] Update RELEASE NOTES.md more enum notes --- RELEASE NOTES.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 6b8729f2..4ae242d1 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -103,6 +103,11 @@ Enumerated types can also be generated from a Haskell algbraic data type with nu >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic >>> instance SOP.Generic Schwarma >>> instance SOP.HasDatatypeInfo Schwarma + +>>> :kind! EnumFrom Schwarma +EnumFrom Schwarma :: PGType += 'PGenum '["Beef", "Lamb", "Chicken"] + >>> :{ let definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] From df89a4ba80ef24d92340df91bc0643105d95a88d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 11:00:36 -0700 Subject: [PATCH 81/92] Update RELEASE NOTES.md composite type notes --- RELEASE NOTES.md | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 4ae242d1..4f71e0ff 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -97,7 +97,7 @@ let CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); ``` -Enumerated types can also be generated from a Haskell algbraic data type with nullary constructors, for example +Enumerated types can also be generated from a Haskell algbraic data type with nullary constructors, for example: ```Haskell >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic @@ -132,8 +132,37 @@ in printSQL expression **Composite Types** +In addition to enum types, you can define composite types. +A composite type represents the structure of a row or record; +it is essentially just a list of field names and their data types. +`createTypeComposite` creates a composite type. The composite type is +specified by a list of attribute names and data types. + +```Haskell +>>> :{ +let + definition :: Definition '[] '["complex" ::: 'Typedef ('PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8])] + definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) +:} +>>> printSQL definition +CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); +``` + +Composite types are almost equivalent to Haskell record types. +However, because of the potential presence of @NULL@ +all the record fields must be `Maybe`s of basic types. +Composite types can be generated from a Haskell record type, for example: + +```Haskell +>>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic +>>> instance SOP.Generic Complex +>>> instance SOP.HasDatatypeInfo Complex +>>> printSQL $ createTypeCompositeFrom @Complex #complex +CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); +``` + ### Version 0.2.1 - April 7, 2018 This minor update fixes an issue where alias identifiers could conflict with From 8e2dfb76232e2b442caabbc84a337c42b0cf7a63 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 11:07:43 -0700 Subject: [PATCH 82/92] Update RELEASE NOTES.md some more composite notes --- RELEASE NOTES.md | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 4f71e0ff..834e5c20 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -159,7 +159,17 @@ Composite types can be generated from a Haskell record type, for example: >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic >>> instance SOP.Generic Complex >>> instance SOP.HasDatatypeInfo Complex ->>> printSQL $ createTypeCompositeFrom @Complex #complex + +>>> :kind! CompositeFrom Complex +CompositeFrom Complex :: PGType += 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)] + +>>> :{ +let + definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)] + definition = createTypeCompositeFrom @Complex #complex +in printSQL definition +:} CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); ``` From 3c5bfcbc5f1730545dfc22e18c62389d0b63d39d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 12:48:13 -0700 Subject: [PATCH 83/92] Update RELEASE NOTES.md more composite notes --- RELEASE NOTES.md | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 834e5c20..9517c6f2 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -85,7 +85,7 @@ a static, ordered set of values. They are equivalent to Haskell algebraic data types whose constructors are nullary. An example of an enum type might be the days of the week, or a set of status values for a piece of data. -Enumerated types are created using the `createTypeEnum` command, for example +Enumerated types are created using the `createTypeEnum` command, for example: ```Haskell >>> :{ @@ -173,6 +173,34 @@ in printSQL definition CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); ``` +A row constructor is an expression that builds a row value +(also called a composite value) using values for its member fields. + +```Haskell +>>> :{ +let + i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex)) + i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) +:} +>>> printSQL i +ROW(0, 1) +``` + +You can also use `(&)` to apply a field label to a composite value. + +```Haskell +>>> :{ +let + expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8) + expr = i & #imaginary +in printSQL expr +:} +(ROW(0, 1)).imaginary +``` + +Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types. +``` + ### Version 0.2.1 - April 7, 2018 This minor update fixes an issue where alias identifiers could conflict with From 6f83d1ad55e7fa8cb7fd2b8e45f6f546558fc30a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 12:48:45 -0700 Subject: [PATCH 84/92] Update RELEASE NOTES.md oops --- RELEASE NOTES.md | 1 - 1 file changed, 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 9517c6f2..02dac8f6 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -199,7 +199,6 @@ in printSQL expr ``` Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types. -``` ### Version 0.2.1 - April 7, 2018 From cad427af038abc779c14f1bbe0c167b7fcab8ae4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 12:49:31 -0700 Subject: [PATCH 85/92] cabal remove -fprint-explicit-kinds --- squeal-postgresql/squeal-postgresql.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index 2a7898e7..8039d01c 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -34,7 +34,7 @@ library Squeal.PostgreSQL.Schema Squeal.PostgreSQL.Transaction default-language: Haskell2010 - ghc-options: -Wall -Werror -fprint-explicit-kinds + ghc-options: -Wall -Werror build-depends: aeson >= 1.2.4.0 , base >= 4.10.1.0 && < 5.0 From 4404cd22c0e3beaebf303d9cdaf0d47bba1e12e8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 13:06:40 -0700 Subject: [PATCH 86/92] Update RELEASE NOTES.md additional changes notes --- RELEASE NOTES.md | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 02dac8f6..2b29e8e2 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -199,6 +199,44 @@ in printSQL expr ``` Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types. +And they can be dropped. + +```Haskell +>>> :{ +let + definition :: Definition '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] '[] + definition = dropType #mood +:} +>>> printSQL definition +DROP TYPE "mood"; +``` + +**Additional Changes** + +Squeal 0.3 also introduces a typeclass `HasAll` similar to `Has` but for a list of aliases. +This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions. + +```Haskell +-- Squeal 0.2 +>>> unique (Column #a :* Column #b :* Nil) + +-- Squeal 0.3 +>>> unique (#a :* #b :* Nil) +``` + +Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as +heterogeneous lists, allowing for some more economy of code. + +```Haskell +-- Squeal 0.2 +>>> select (#a `As` #a :* Nil) (from (table (#t `As` #t))) + +-- Squeal 0.3 +>>> select #a (from (table #t)) +``` + +The above changes required major and minor changes to Squeal DSL functions. +Please consult the documentation. ### Version 0.2.1 - April 7, 2018 From e6857fcdc84851cc5816656d4c4f902dabcc7502 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 13:10:13 -0700 Subject: [PATCH 87/92] Update RELEASE NOTES.md --- RELEASE NOTES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 2b29e8e2..db2e7fb6 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -151,7 +151,7 @@ CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); ``` Composite types are almost equivalent to Haskell record types. -However, because of the potential presence of @NULL@ +However, because of the potential presence of `NULL` all the record fields must be `Maybe`s of basic types. Composite types can be generated from a Haskell record type, for example: From f43c53d3deea3f47e12ac4b8681ac0e9bc591af5 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 13:20:43 -0700 Subject: [PATCH 88/92] Update RELEASE NOTES.md --- RELEASE NOTES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index db2e7fb6..db8d0149 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -235,6 +235,8 @@ heterogeneous lists, allowing for some more economy of code. >>> select #a (from (table #t)) ``` +Squeal 0.3 also fixes a bug that prevented joined queries on self-referencing tables. + The above changes required major and minor changes to Squeal DSL functions. Please consult the documentation. From 028fcb7dbb5def163909f5d792bc92664f614263 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 25 Jun 2018 13:22:00 -0700 Subject: [PATCH 89/92] Update RELEASE NOTES.md June 27 --- RELEASE NOTES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index db8d0149..7de818dc 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -1,6 +1,6 @@ ## RELEASE NOTES -### Version 0.3 - June 23, 2018 +### Version 0.3 - June 27, 2018 Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal. To support these features, a new kind `SchemumType` was added. From b5e8b4262b4bac99b08d993b0911f5c207340cda Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 26 Jun 2018 09:19:35 -0700 Subject: [PATCH 90/92] Update RELEASE NOTES.md --- RELEASE NOTES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 7de818dc..73cf5fac 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -228,7 +228,7 @@ Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as heterogeneous lists, allowing for some more economy of code. ```Haskell --- Squeal 0.2 +-- Squeal 0.2 (or 0.3) >>> select (#a `As` #a :* Nil) (from (table (#t `As` #t))) -- Squeal 0.3 From fc14f92ca83fa3f0675f2c47ec2affa91405bcf1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 26 Jun 2018 09:19:50 -0700 Subject: [PATCH 91/92] Update RELEASE NOTES.md --- RELEASE NOTES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md index 73cf5fac..f28b9adc 100644 --- a/RELEASE NOTES.md +++ b/RELEASE NOTES.md @@ -1,6 +1,6 @@ ## RELEASE NOTES -### Version 0.3 - June 27, 2018 +### Version 0.3 - June 26, 2018 Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal. To support these features, a new kind `SchemumType` was added. From b3ccfb0d45e528f7eb423f618a54089a6c0cb35e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 26 Jun 2018 09:24:23 -0700 Subject: [PATCH 92/92] circle --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 3379c2b1..86eef77c 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -12,7 +12,7 @@ jobs: keys: - dependency-cache - run: apt-get update && apt-get install -y libpq-dev xz-utils make - - run: stack setup && stack upgrade && stack update + - run: stack upgrade && stack update - run: stack build - run: stack test - run: stack haddock