a00c12b · squeal · git.iko.soy

git.iko.soy/squeal

commons & schemas

commita00c12be33b75468645c27a8c02d0d7d1d88abe0 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 3 Dec 2018, 20:45 (8 years ago) parentb2cd1ef

11 files changed+359−337

compare with dev

unifiedsplit

squeal-postgresql/exe/Example.hs+8−4

@@ -6,6 +6,8 @@

66 , OverloadedStrings

77 , OverloadedLists

88 , TypeApplications

9+ , TypeFamilies

10+ , TypeInType

911 , TypeOperators

1012#-}

1113

@@ -41,9 +43,11 @@ type Schema =

4143 ])

4244 ]

4345

44−type DB = '["public" ::: Schema]

46+type family Schemas0 :: SchemasType where Schemas0 = '["public" ::: '[]]

47+type family Schemas :: SchemasType where Schemas = '["public" ::: Schema]

48+type DB = '[] :=> Schemas

4549

46−setup :: Definition '["public" ::: '[]] DB

50+setup :: Definition Schemas0 Schemas

4751setup =

4852 createTable #users

4953 ( serial `as` #id :*

@@ -59,7 +63,7 @@ setup =

5963 foreignKey #user_id #users #id

6064 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

6165

62−teardown :: Definition DB '["public" ::: '[]]

66+teardown :: Definition Schemas Schemas0

6367teardown = dropTable #emails >>> dropTable #users

6468

6569insertUser :: Manipulation DB '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]

@@ -97,7 +101,7 @@ users =

97101 , User "Carole" (Just "carole@hotmail.com") [Just 3]

98102 ]

99103

100−session :: (MonadBase IO pq, MonadPQ DB pq) => pq ()

104+session :: (MonadBase IO pq, MonadPQ Schemas pq) => pq ()

101105session = do

102106 liftBase $ Char8.putStrLn "manipulating"

103107 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])

squeal-postgresql/src/Squeal/PostgreSQL.hs+1−1

@@ -51,7 +51,7 @@ type DB = '[ "public" ::: Schema ]

5151

5252Notice the use of type operators.

5353

54−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `DBType`, a `SchemumType`,

54+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`,

5555a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@

5656operator.

5757

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+96−96

@@ -110,12 +110,12 @@ statements

110110-- database, like a `createTable`, `dropTable`, or `alterTable` command.

111111-- `Definition`s may be composed using the `>>>` operator.

112112newtype Definition

113− (db0 :: DBType)

114− (db1 :: DBType)

113+ (schemas0 :: SchemasType)

114+ (schemas1 :: SchemasType)

115115 = UnsafeDefinition { renderDefinition :: ByteString }

116116 deriving (GHC.Generic,Show,Eq,Ord,NFData)

117117

118−instance RenderSQL (Definition db0 db1) where

118+instance RenderSQL (Definition schemas0 schemas1) where

119119 renderSQL = renderDefinition

120120

121121instance Category Definition where

@@ -130,14 +130,14 @@ CREATE statements

130130createSchema

131131 :: KnownSymbol sch

132132 => Alias sch

133− -> Definition db (Create sch '[] db)

133+ -> Definition schemas (Create sch '[] schemas)

134134createSchema sch = UnsafeDefinition $

135135 "CREATE" <+> "SCHEMA" <+> renderAlias sch <> ";"

136136

137137createSchemaIfNotExists

138− :: (KnownSymbol sch, Has sch db schema)

138+ :: (KnownSymbol sch, Has sch schemas schema)

139139 => Alias sch

140− -> Definition db db

140+ -> Definition schemas schemas

141141createSchemaIfNotExists sch = UnsafeDefinition $

142142 "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"

143143 <+> renderAlias sch <> ";"

@@ -166,14 +166,14 @@ createTable

166166 , columns ~ (col ': cols)

167167 , SOP.SListI columns

168168 , SOP.SListI constraints

169− , Has sch db0 schema0

170− , db1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) db0 )

169+ , Has sch schemas0 schema0

170+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )

171171 => QualifiedAlias sch tab -- ^ the name of the table to add

172− -> NP (Aliased (ColumnTypeExpression db0)) columns

172+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

173173 -- ^ the names and datatype of each column

174− -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints

174+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

175175 -- ^ constraints that must hold for the table

176− -> Definition db0 db1

176+ -> Definition schemas0 schemas1

177177createTable tab columns constraints = UnsafeDefinition $

178178 "CREATE TABLE" <+> renderCreation tab columns constraints

179179

@@ -201,16 +201,16 @@ in printSQL setup

201201CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);

202202-}

203203createTableIfNotExists

204− :: ( Has sch db schema

204+ :: ( Has sch schemas schema

205205 , Has tab schema ('Table (constraints :=> columns))

206206 , SOP.SListI columns

207207 , SOP.SListI constraints )

208208 => QualifiedAlias sch tab -- ^ the name of the table to add

209− -> NP (Aliased (ColumnTypeExpression db)) columns

209+ -> NP (Aliased (ColumnTypeExpression schemas)) columns

210210 -- ^ the names and datatype of each column

211− -> NP (Aliased (TableConstraintExpression sch tab db)) constraints

211+ -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints

212212 -- ^ constraints that must hold for the table

213− -> Definition db db

213+ -> Definition schemas schemas

214214createTableIfNotExists tab columns constraints = UnsafeDefinition $

215215 "CREATE TABLE IF NOT EXISTS"

216216 <+> renderCreation tab columns constraints

@@ -222,9 +222,9 @@ renderCreation

222222 , SOP.SListI columns

223223 , SOP.SListI constraints )

224224 => QualifiedAlias sch tab -- ^ the name of the table to add

225− -> NP (Aliased (ColumnTypeExpression db0)) columns

225+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

226226 -- ^ the names and datatype of each column

227− -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints

227+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

228228 -- ^ constraints that must hold for the table

229229 -> ByteString

230230renderCreation tab columns constraints = renderQualifiedAlias tab

@@ -236,11 +236,11 @@ renderCreation tab columns constraints = renderQualifiedAlias tab

236236 renderCommaSeparated renderConstraint constraints ) )

237237 <> ";"

238238 where

239− renderColumnDef :: Aliased (ColumnTypeExpression db) x -> ByteString

239+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString

240240 renderColumnDef (ty `As` column) =

241241 renderAlias column <+> renderColumnTypeExpression ty

242242 renderConstraint

243− :: Aliased (TableConstraintExpression sch tab db) constraint

243+ :: Aliased (TableConstraintExpression sch tab schemas) constraint

244244 -> ByteString

245245 renderConstraint (constraint `As` alias) =

246246 "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint

@@ -260,7 +260,7 @@ renderCreation tab columns constraints = renderQualifiedAlias tab

260260newtype TableConstraintExpression

261261 (sch :: Symbol)

262262 (tab :: Symbol)

263− (db :: DBType)

263+ (schemas :: SchemasType)

264264 (constraint :: TableConstraint)

265265 = UnsafeTableConstraintExpression

266266 { renderTableConstraintExpression :: ByteString }

@@ -291,14 +291,14 @@ let

291291CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));

292292-}

293293check

294− :: ( Has sch db schema

294+ :: ( Has sch schemas schema

295295 , Has tab schema ('Table table)

296296 , HasAll aliases (TableToRow table) subcolumns )

297297 => NP Alias aliases

298298 -- ^ specify the subcolumns which are getting checked

299− -> (forall t. Condition db '[t ::: subcolumns] 'Ungrouped '[])

299+ -> (forall t. Condition ('[] :=> schemas) '[t ::: subcolumns] 'Ungrouped '[])

300300 -- ^ a closed `Condition` on those subcolumns

301− -> TableConstraintExpression sch tab db ('Check aliases)

301+ -> TableConstraintExpression sch tab schemas ('Check aliases)

302302check _cols condition = UnsafeTableConstraintExpression $

303303 "CHECK" <+> parenthesized (renderExpression condition)

304304

@@ -326,12 +326,12 @@ let

326326CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));

327327-}

328328unique

329− :: ( Has sch db schema

329+ :: ( Has sch schemas schema

330330 , Has tab schema('Table table)

331331 , HasAll aliases (TableToRow table) subcolumns )

332332 => NP Alias aliases

333333 -- ^ specify subcolumns which together are unique for each row

334− -> TableConstraintExpression sch tab db ('Unique aliases)

334+ -> TableConstraintExpression sch tab schemas ('Unique aliases)

335335unique columns = UnsafeTableConstraintExpression $

336336 "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))

337337

@@ -361,13 +361,13 @@ let

361361CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));

362362-}

363363primaryKey

364− :: ( Has sch db schema

364+ :: ( Has sch schemas schema

365365 , Has tab schema ('Table table)

366366 , HasAll aliases (TableToColumns table) subcolumns

367367 , AllNotNull subcolumns )

368368 => NP Alias aliases

369369 -- ^ specify the subcolumns which together form a primary key.

370− -> TableConstraintExpression sch tab db ('PrimaryKey aliases)

370+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)

371371primaryKey columns = UnsafeTableConstraintExpression $

372372 "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))

373373

@@ -445,7 +445,7 @@ in printSQL setup

445445CREATE 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);

446446-}

447447foreignKey

448− :: (ForeignKeyed db sch schema child parent

448+ :: (ForeignKeyed schemas sch schema child parent

449449 table reftable

450450 columns refcolumns

451451 constraints cols

@@ -460,7 +460,7 @@ foreignKey

460460 -- ^ what to do when reference is deleted

461461 -> OnUpdateClause

462462 -- ^ what to do when reference is updated

463− -> TableConstraintExpression sch child db

463+ -> TableConstraintExpression sch child schemas

464464 ('ForeignKey columns parent refcolumns)

465465foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

466466 "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))

@@ -470,7 +470,7 @@ foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

470470 <+> renderOnUpdateClause onupd

471471

472472-- | A constraint synonym between types involved in a foreign key constraint.

473−type ForeignKeyed db

473+type ForeignKeyed schemas

474474 sch

475475 schema

476476 child parent

@@ -478,7 +478,7 @@ type ForeignKeyed db

478478 columns refcolumns

479479 constraints cols

480480 reftys tys =

481− ( Has sch db schema

481+ ( Has sch schemas schema

482482 , Has child schema ('Table table)

483483 , Has parent schema ('Table reftable)

484484 , HasAll columns (TableToColumns table) tys

@@ -541,10 +541,10 @@ DROP statements

541541-- >>> printSQL definition

542542-- DROP TABLE "muh_table";

543543dropTable

544− :: ( Has sch db schema

544+ :: ( Has sch schemas schema

545545 , Has tab schema ('Table table))

546546 => QualifiedAlias sch tab -- ^ table to remove

547− -> Definition db (Alter sch (Drop tab schema) db)

547+ -> Definition schemas (Alter sch (Drop tab schema) schemas)

548548dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderQualifiedAlias tab <> ";"

549549

550550{-----------------------------------------

@@ -553,10 +553,10 @@ ALTER statements

553553

554554-- | `alterTable` changes the definition of a table from the schema.

555555alterTable

556− :: (Has sch db schema, Has tab schema ('Table table0))

556+ :: (Has sch schemas schema, Has tab schema ('Table table0))

557557 => QualifiedAlias sch tab -- ^ table to alter

558− -> AlterTable sch tab db table1 -- ^ alteration to perform

559− -> Definition db (Alter sch (Alter tab ('Table table1) schema) db)

558+ -> AlterTable sch tab schemas table1 -- ^ alteration to perform

559+ -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)

560560alterTable tab alteration = UnsafeDefinition $

561561 "ALTER TABLE"

562562 <+> renderQualifiedAlias tab

@@ -581,7 +581,7 @@ alterTableRename table0 table1 = UnsafeDefinition $

581581newtype AlterTable

582582 (sch :: Symbol)

583583 (tab :: Symbol)

584− (db :: DBType)

584+ (schemas :: SchemasType)

585585 (table :: TableType) =

586586 UnsafeAlterTable {renderAlterTable :: ByteString}

587587 deriving (GHC.Generic,Show,Eq,Ord,NFData)

@@ -599,14 +599,14 @@ newtype AlterTable

599599-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));

600600addConstraint

601601 :: ( KnownSymbol alias

602− , Has sch db schema

602+ , Has sch schemas schema

603603 , Has tab schema ('Table table0)

604604 , table0 ~ (constraints :=> columns)

605605 , table1 ~ (Create alias constraint constraints :=> columns) )

606606 => Alias alias

607− -> TableConstraintExpression sch tab db constraint

607+ -> TableConstraintExpression sch tab schemas constraint

608608 -- ^ constraint to add

609− -> AlterTable sch tab db table1

609+ -> AlterTable sch tab schemas table1

610610addConstraint alias constraint = UnsafeAlterTable $

611611 "ADD" <+> "CONSTRAINT" <+> renderAlias alias

612612 <+> renderTableConstraintExpression constraint

@@ -624,13 +624,13 @@ addConstraint alias constraint = UnsafeAlterTable $

624624-- ALTER TABLE "tab" DROP CONSTRAINT "positive";

625625dropConstraint

626626 :: ( KnownSymbol constraint

627− , Has sch db schema

627+ , Has sch schemas schema

628628 , Has tab schema ('Table table0)

629629 , table0 ~ (constraints :=> columns)

630630 , table1 ~ (Drop constraint constraints :=> columns) )

631631 => Alias constraint

632632 -- ^ constraint to drop

633− -> AlterTable sch tab db table1

633+ -> AlterTable sch tab schemas table1

634634dropConstraint constraint = UnsafeAlterTable $

635635 "DROP" <+> "CONSTRAINT" <+> renderAlias constraint

636636

@@ -664,12 +664,12 @@ class AddColumn ty where

664664 -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;

665665 addColumn

666666 :: ( KnownSymbol column

667− , Has sch db schema

667+ , Has sch schemas schema

668668 , Has tab schema ('Table table0)

669669 , table0 ~ (constraints :=> columns) )

670670 => Alias column -- ^ column to add

671− -> ColumnTypeExpression db ty -- ^ type of the new column

672− -> AlterTable sch tab db (constraints :=> Create column ty columns)

671+ -> ColumnTypeExpression schemas ty -- ^ type of the new column

672+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)

673673 addColumn column ty = UnsafeAlterTable $

674674 "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty

675675instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)

@@ -693,12 +693,12 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)

693693-- ALTER TABLE "tab" DROP COLUMN "col2";

694694dropColumn

695695 :: ( KnownSymbol column

696− , Has sch db schema

696+ , Has sch schemas schema

697697 , Has tab schema ('Table table0)

698698 , table0 ~ (constraints :=> columns)

699699 , table1 ~ (constraints :=> Drop column columns) )

700700 => Alias column -- ^ column to remove

701− -> AlterTable sch tab db table1

701+ -> AlterTable sch tab schemas table1

702702dropColumn column = UnsafeAlterTable $

703703 "DROP COLUMN" <+> renderAlias column

704704

@@ -716,32 +716,32 @@ dropColumn column = UnsafeAlterTable $

716716renameColumn

717717 :: ( KnownSymbol column0

718718 , KnownSymbol column1

719− , Has sch db schema

719+ , Has sch schemas schema

720720 , Has tab schema ('Table table0)

721721 , table0 ~ (constraints :=> columns)

722722 , table1 ~ (constraints :=> Rename column0 column1 columns) )

723723 => Alias column0 -- ^ column to rename

724724 -> Alias column1 -- ^ what to rename the column

725− -> AlterTable sch tab db table1

725+ -> AlterTable sch tab schemas table1

726726renameColumn column0 column1 = UnsafeAlterTable $

727727 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1

728728

729729-- | An `alterColumn` alters a single column.

730730alterColumn

731731 :: ( KnownSymbol column

732− , Has sch db schema

732+ , Has sch schemas schema

733733 , Has tab schema ('Table table0)

734734 , table0 ~ (constraints :=> columns)

735735 , Has column columns ty0

736736 , tables1 ~ (constraints :=> Alter column ty1 columns))

737737 => Alias column -- ^ column to alter

738− -> AlterColumn db ty0 ty1 -- ^ alteration to perform

739− -> AlterTable sch tab db table1

738+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform

739+ -> AlterTable sch tab schemas table1

740740alterColumn column alteration = UnsafeAlterTable $

741741 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration

742742

743743-- | An `AlterColumn` describes the alteration to perform on a single column.

744−newtype AlterColumn (db :: DBType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

744+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

745745 UnsafeAlterColumn {renderAlterColumn :: ByteString}

746746 deriving (GHC.Generic,Show,Eq,Ord,NFData)

747747

@@ -759,8 +759,8 @@ newtype AlterColumn (db :: DBType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

759759-- :}

760760-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;

761761setDefault

762− :: Expression db '[] 'Ungrouped '[] ty -- ^ default value to set

763− -> AlterColumn db (constraint :=> ty) ('Def :=> ty)

762+ :: Expression ('[] :=> schemas) '[] 'Ungrouped '[] ty -- ^ default value to set

763+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)

764764setDefault expression = UnsafeAlterColumn $

765765 "SET DEFAULT" <+> renderExpression expression

766766

@@ -775,7 +775,7 @@ setDefault expression = UnsafeAlterColumn $

775775-- in printSQL definition

776776-- :}

777777-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;

778−dropDefault :: AlterColumn db ('Def :=> ty) ('NoDef :=> ty)

778+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)

779779dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

780780

781781-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.

@@ -792,7 +792,7 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

792792-- :}

793793-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;

794794setNotNull

795− :: AlterColumn db (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

795+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

796796setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

797797

798798-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.

@@ -807,7 +807,7 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

807807-- :}

808808-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;

809809dropNotNull

810− :: AlterColumn db (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

810+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

811811dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

812812

813813-- | An `alterType` converts a column to a different data type.

@@ -824,7 +824,7 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

824824-- in printSQL definition

825825-- :}

826826-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;

827−alterType :: ColumnTypeExpression db ty -> AlterColumn db ty0 ty

827+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty

828828alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty

829829

830830{- | Create a view.

@@ -842,10 +842,10 @@ in printSQL definition

842842CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";

843843-}

844844createView

845− :: (KnownSymbol sch, KnownSymbol vw, Has sch db schema)

845+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)

846846 => QualifiedAlias sch vw -- ^ the name of the view to add

847− -> Query db '[] view -- ^ query

848− -> Definition db (Alter sch (Create vw ('View view) schema) db)

847+ -> Query ('[] :=> schemas) '[] view -- ^ query

848+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)

849849createView alias query = UnsafeDefinition $

850850 "CREATE" <+> "VIEW" <+> renderQualifiedAlias alias <+> "AS"

851851 <+> renderQuery query <> ";"

@@ -863,9 +863,9 @@ createView alias query = UnsafeDefinition $

863863-- :}

864864-- DROP VIEW "bc";

865865dropView

866− :: (Has sch db schema, Has vw schema ('View view))

866+ :: (Has sch schemas schema, Has vw schema ('View view))

867867 => QualifiedAlias sch vw -- ^ view to remove

868− -> Definition db (Alter sch (Drop vw schema) db)

868+ -> Definition schemas (Alter sch (Drop vw schema) schemas)

869869dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderQualifiedAlias vw <> ";"

870870

871871-- | Enumerated types are created using the `createTypeEnum` command, for example

@@ -873,12 +873,12 @@ dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderQualifiedAlias vw <> ";"

873873-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition '["public" ::: '[]] '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])

874874-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');

875875createTypeEnum

876− :: (KnownSymbol enum, Has sch db schema, SOP.All KnownSymbol labels)

876+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)

877877 => QualifiedAlias sch enum

878878 -- ^ name of the user defined enumerated type

879879 -> NP PGlabel labels

880880 -- ^ labels of the enumerated type

881− -> Definition db (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) db)

881+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)

882882createTypeEnum enum labels = UnsafeDefinition $

883883 "CREATE" <+> "TYPE" <+> renderQualifiedAlias enum <+> "AS" <+> "ENUM" <+>

884884 parenthesized (commaSeparated (renderLabels labels)) <> ";"

@@ -897,14 +897,14 @@ createTypeEnum enum labels = UnsafeDefinition $

897897-- :}

898898-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');

899899createTypeEnumFrom

900− :: forall hask sch enum db schema.

900+ :: forall hask sch enum schemas schema.

901901 ( SOP.Generic hask

902902 , SOP.All KnownSymbol (LabelsPG hask)

903903 , KnownSymbol enum

904− , Has sch db schema )

904+ , Has sch schemas schema )

905905 => QualifiedAlias sch enum

906906 -- ^ name of the user defined enumerated type

907− -> Definition db (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) db)

907+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)

908908createTypeEnumFrom enum = createTypeEnum enum

909909 (SOP.hpure label :: NP PGlabel (LabelsPG hask))

910910

@@ -927,17 +927,17 @@ in printSQL setup

927927CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

928928-}

929929createTypeComposite

930− :: (KnownSymbol ty, Has sch db schema, SOP.SListI fields)

930+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)

931931 => QualifiedAlias sch ty

932932 -- ^ name of the user defined composite type

933− -> NP (Aliased (TypeExpression db)) fields

933+ -> NP (Aliased (TypeExpression schemas)) fields

934934 -- ^ list of attribute names and data types

935− -> Definition db (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) db)

935+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)

936936createTypeComposite ty fields = UnsafeDefinition $

937937 "CREATE" <+> "TYPE" <+> renderQualifiedAlias ty <+> "AS" <+> parenthesized

938938 (renderCommaSeparated renderField fields) <> ";"

939939 where

940− renderField :: Aliased (TypeExpression db) x -> ByteString

940+ renderField :: Aliased (TypeExpression schemas) x -> ByteString

941941 renderField (typ `As` alias) =

942942 renderAlias alias <+> renderTypeExpression typ

943943

@@ -956,21 +956,21 @@ createTypeComposite ty fields = UnsafeDefinition $

956956-- :}

957957-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

958958createTypeCompositeFrom

959− :: forall hask sch ty db schema.

960− ( SOP.All (FieldTyped db) (RowPG hask)

959+ :: forall hask sch ty schemas schema.

960+ ( SOP.All (FieldTyped schemas) (RowPG hask)

961961 , KnownSymbol ty

962− , Has sch db schema )

962+ , Has sch schemas schema )

963963 => QualifiedAlias sch ty

964964 -- ^ name of the user defined composite type

965− -> Definition db (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) db)

965+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)

966966createTypeCompositeFrom ty = createTypeComposite ty

967− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped db)) fieldtype

968− :: NP (Aliased (TypeExpression db)) (RowPG hask))

967+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype

968+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))

969969

970−class FieldTyped db ty where

971− fieldtype :: Aliased (TypeExpression db) ty

972−instance (KnownSymbol alias, PGTyped db ty)

973− => FieldTyped db (alias ::: ty) where

970+class FieldTyped schemas ty where

971+ fieldtype :: Aliased (TypeExpression schemas) ty

972+instance (KnownSymbol alias, PGTyped schemas ty)

973+ => FieldTyped schemas (alias ::: ty) where

974974 fieldtype = pgtype `As` Alias

975975

976976-- | Drop a type.

@@ -981,54 +981,54 @@ instance (KnownSymbol alias, PGTyped db ty)

981981-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] '["public" ::: '[]])

982982-- DROP TYPE "schwarma";

983983dropType

984− :: (Has sch db schema, Has td schema ('Typedef ty))

984+ :: (Has sch schemas schema, Has td schema ('Typedef ty))

985985 => QualifiedAlias sch td

986986 -- ^ name of the user defined type

987− -> Definition db (Alter sch (Drop td schema) db)

987+ -> Definition schemas (Alter sch (Drop td schema) schemas)

988988dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderQualifiedAlias tydef <> ";"

989989

990990-- | `ColumnTypeExpression`s are used in `createTable` commands.

991−newtype ColumnTypeExpression (db :: DBType) (ty :: ColumnType)

991+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)

992992 = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

993993 deriving (GHC.Generic,Show,Eq,Ord,NFData)

994994

995995-- | used in `createTable` commands as a column constraint to note that

996996-- @NULL@ may be present in a column

997997nullable

998− :: TypeExpression db (nullity ty)

999− -> ColumnTypeExpression db ('NoDef :=> 'Null ty)

998+ :: TypeExpression schemas (nullity ty)

999+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)

10001000nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"

10011001

10021002-- | used in `createTable` commands as a column constraint to ensure

10031003-- @NULL@ is not present in a column

10041004notNullable

1005− :: TypeExpression db (nullity ty)

1006− -> ColumnTypeExpression db ('NoDef :=> 'NotNull ty)

1005+ :: TypeExpression schemas (nullity ty)

1006+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)

10071007notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

10081008

10091009-- | used in `createTable` commands as a column constraint to give a default

10101010default_

1011− :: Expression db '[] 'Ungrouped '[] ty

1012− -> ColumnTypeExpression db ('NoDef :=> ty)

1013− -> ColumnTypeExpression db ('Def :=> ty)

1011+ :: Expression ('[] :=> schemas) '[] 'Ungrouped '[] ty

1012+ -> ColumnTypeExpression schemas ('NoDef :=> ty)

1013+ -> ColumnTypeExpression schemas ('Def :=> ty)

10141014default_ x ty = UnsafeColumnTypeExpression $

10151015 renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x

10161016

10171017-- | not a true type, but merely a notational convenience for creating

10181018-- unique identifier columns with type `PGint2`

10191019serial2, smallserial

1020− :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint2)

1020+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)

10211021serial2 = UnsafeColumnTypeExpression "serial2"

10221022smallserial = UnsafeColumnTypeExpression "smallserial"

10231023-- | not a true type, but merely a notational convenience for creating

10241024-- unique identifier columns with type `PGint4`

10251025serial4, serial

1026− :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint4)

1026+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)

10271027serial4 = UnsafeColumnTypeExpression "serial4"

10281028serial = UnsafeColumnTypeExpression "serial"

10291029-- | not a true type, but merely a notational convenience for creating

10301030-- unique identifier columns with type `PGint8`

10311031serial8, bigserial

1032− :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint8)

1032+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)

10331033serial8 = UnsafeColumnTypeExpression "serial8"

10341034bigserial = UnsafeColumnTypeExpression "bigserial"

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+23−24

@@ -238,7 +238,6 @@ refer to the out-of-line data values.

238238-}

239239class KnownNat n => HasParameter

240240 (n :: Nat)

241− (db :: DBType)

242241 (params :: [NullityType])

243242 (ty :: NullityType)

244243 | n params -> ty where

@@ -248,14 +247,14 @@ class KnownNat n => HasParameter

248247 -- >>> printSQL expr

249248 -- ($1 :: int4)

250249 parameter

251− :: TypeExpression db ty

252− -> Expression db from grouping params ty

250+ :: TypeExpression schemas ty

251+ -> Expression (commons :=> schemas) from grouping params ty

253252 parameter ty = UnsafeExpression $ parenthesized $

254253 "$" <> renderNat @n <+> "::"

255254 <+> renderTypeExpression ty

256−instance {-# OVERLAPPING #-} HasParameter 1 db (ty1:tys) ty1

257−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) db params ty)

258− => HasParameter n db (ty' : params) ty

255+instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1

256+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

257+ => HasParameter n (ty' : params) ty

259258

260259-- | `param` takes a `Nat` using type application and for basic types,

261260-- infers a `TypeExpression`.

@@ -264,9 +263,9 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) db params ty)

264263-- >>> printSQL expr

265264-- ($1 :: int4)

266265param

267− :: forall n db params from grouping ty

268− . (PGTyped db ty, HasParameter n db params ty)

269− => Expression db from grouping params ty -- ^ param

266+ :: forall n commons schemas params from grouping ty

267+ . (PGTyped schemas ty, HasParameter n params ty)

268+ => Expression (commons :=> schemas) from grouping params ty -- ^ param

270269param = parameter @n pgtype

271270

272271instance (HasUnique table from columns, Has column columns ty)

@@ -486,13 +485,13 @@ row exprs = UnsafeExpression $ "ROW" <> parenthesized

486485-- >>> printSQL $ i & field #complex #imaginary

487486-- (ROW(0, 1)::"complex")."imaginary"

488487field

489− :: ( Has sch db schema

488+ :: ( Has sch schemas schema

490489 , Has tydef schema ('Typedef ('PGcomposite row))

491490 , Has field row ty)

492491 => QualifiedAlias sch tydef -- ^ row type

493492 -> Alias field -- ^ field name

494− -> Expression db from grouping params ('NotNull ('PGcomposite row))

495− -> Expression db from grouping params ty

493+ -> Expression (commons :=> schemas) from grouping params ('NotNull ('PGcomposite row))

494+ -> Expression (commons :=> schemas) from grouping params ty

496495field td fld expr = UnsafeExpression $

497496 parenthesized (renderExpression expr <> "::" <> renderQualifiedAlias td)

498497 <> "." <> renderAlias fld

@@ -633,11 +632,11 @@ atan2_ y x = UnsafeExpression $

633632-- | >>> printSQL $ true & cast int4

634633-- (TRUE :: int4)

635634cast

636− :: TypeExpression db ty1

635+ :: TypeExpression schemas ty1

637636 -- ^ type to cast as

638− -> Expression db from grouping params ty0

637+ -> Expression (commons :=> schemas) from grouping params ty0

639638 -- ^ value to convert

640− -> Expression db from grouping params ty1

639+ -> Expression (commons :=> schemas) from grouping params ty1

641640cast ty x = UnsafeExpression $ parenthesized $

642641 renderExpression x <+> "::" <+> renderTypeExpression ty

643642

@@ -1090,14 +1089,14 @@ Table 9.45: JSON creation functions

10901089-- | Literal binary JSON

10911090jsonbLit

10921091 :: JSON.ToJSON x

1093− => x -> Expression db from grouping params (nullity 'PGjsonb)

1092+ => x -> Expression (commons :=> schemas) from grouping params (nullity 'PGjsonb)

10941093jsonbLit = cast jsonb . UnsafeExpression

10951094 . singleQuotedUtf8 . toStrict . JSON.encode

10961095

10971096-- | Literal JSON

10981097jsonLit

10991098 :: JSON.ToJSON x

1100− => x -> Expression db from grouping params (nullity 'PGjson)

1099+ => x -> Expression (commons :=> schemas) from grouping params (nullity 'PGjson)

11011100jsonLit = cast json . UnsafeExpression

11021101 . singleQuotedUtf8 . toStrict . JSON.encode

11031102

@@ -1610,31 +1609,31 @@ type expressions

16101609-----------------------------------------}

16111610

16121611-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1613−newtype TypeExpression (db :: DBType) (ty :: NullityType)

1612+newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)

16141613 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

16151614 deriving (GHC.Generic,Show,Eq,Ord,NFData)

16161615

16171616-- | The enum or composite type in a `Typedef` can be expressed by its alias.

16181617typedef

1619− :: (Has sch db schema, Has td schema ('Typedef ty))

1618+ :: (Has sch schemas schema, Has td schema ('Typedef ty))

16201619 => QualifiedAlias sch td

1621− -> TypeExpression db (nullity ty)

1620+ -> TypeExpression schemas (nullity ty)

16221621typedef = UnsafeTypeExpression . renderQualifiedAlias

16231622

16241623-- | The composite type corresponding to a `Table` definition can be expressed

16251624-- by its alias.

16261625typetable

1627− :: (Has sch db schema, Has tab schema ('Table table))

1626+ :: (Has sch schemas schema, Has tab schema ('Table table))

16281627 => QualifiedAlias sch tab

1629− -> TypeExpression db (nullity ('PGcomposite (TableToRow table)))

1628+ -> TypeExpression schemas (nullity ('PGcomposite (TableToRow table)))

16301629typetable = UnsafeTypeExpression . renderQualifiedAlias

16311630

16321631-- | The composite type corresponding to a `View` definition can be expressed

16331632-- by its alias.

16341633typeview

1635− :: (Has sch db schema, Has vw schema ('View view))

1634+ :: (Has sch schemas schema, Has vw schema ('View view))

16361635 => QualifiedAlias sch vw

1637− -> TypeExpression db (nullity ('PGcomposite view))

1636+ -> TypeExpression schemas (nullity ('PGcomposite view))

16381637typeview = UnsafeTypeExpression . renderQualifiedAlias

16391638

16401639-- | logical Boolean (true/false)

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+20−10

@@ -230,7 +230,8 @@ INSERT statements

230230insertRows

231231 :: ( SOP.SListI columns

232232 , SOP.SListI results

233− , Has sch db schema

233+ , db ~ (commons :=> schemas)

234+ , Has sch schemas schema

234235 , Has tab schema ('Table table)

235236 , row ~ TableToRow table

236237 , columns ~ TableToColumns table )

@@ -262,7 +263,8 @@ insertRows tab rw rws conflict returning = UnsafeManipulation $

262263insertRow

263264 :: ( SOP.SListI columns

264265 , SOP.SListI results

265− , Has sch db schema

266+ , db ~ (commons :=> schemas)

267+ , Has sch schemas schema

266268 , Has tab schema ('Table table)

267269 , row ~ TableToRow table

268270 , columns ~ TableToColumns table )

@@ -277,7 +279,8 @@ insertRow tab rw = insertRows tab rw []

277279-- | Insert multiple rows returning `Nil` and raising an error on conflicts.

278280insertRows_

279281 :: ( SOP.SListI columns

280− , Has sch db schema

282+ , db ~ (commons :=> schemas)

283+ , Has sch schemas schema

281284 , Has tab schema ('Table table)

282285 , columns ~ TableToColumns table )

283286 => QualifiedAlias sch tab -- ^ table to insert into

@@ -290,7 +293,8 @@ insertRows_ tab rw rws =

290293-- | Insert a single row returning `Nil` and raising an error on conflicts.

291294insertRow_

292295 :: ( SOP.SListI columns

293− , Has sch db schema

296+ , db ~ (commons :=> schemas)

297+ , Has sch schemas schema

294298 , Has tab schema ('Table table)

295299 , columns ~ TableToColumns table )

296300 => QualifiedAlias sch tab -- ^ table to insert into

@@ -302,7 +306,8 @@ insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)

302306insertQuery

303307 :: ( SOP.SListI columns

304308 , SOP.SListI results

305− , Has sch db schema

309+ , db ~ (commons :=> schemas)

310+ , Has sch schemas schema

306311 , Has tab schema ('Table table)

307312 , row ~ TableToRow table

308313 , columns ~ TableToColumns table )

@@ -321,7 +326,8 @@ insertQuery tab query conflict returning = UnsafeManipulation $

321326-- | Insert a `Query` returning `Nil` and raising an error on conflicts.

322327insertQuery_

323328 :: ( SOP.SListI columns

324− , Has sch db schema

329+ , db ~ (commons :=> schemas)

330+ , Has sch schemas schema

325331 , Has tab schema ('Table table)

326332 , columns ~ TableToColumns table )

327333 => QualifiedAlias sch tab -- ^ table to insert into

@@ -431,7 +437,8 @@ UPDATE statements

431437update

432438 :: ( SOP.SListI columns

433439 , SOP.SListI results

434− , Has sch db schema

440+ , db ~ (commons :=> schemas)

441+ , Has sch schemas schema

435442 , Has tab schema ('Table table)

436443 , row ~ TableToRow table

437444 , columns ~ TableToColumns table )

@@ -463,7 +470,8 @@ update tab columns wh returning = UnsafeManipulation $

463470-- | Update a row returning `Nil`.

464471update_

465472 :: ( SOP.SListI columns

466− , Has sch db schema

473+ , db ~ (commons :=> schemas)

474+ , Has sch schemas schema

467475 , Has tab schema ('Table table)

468476 , row ~ TableToRow table

469477 , columns ~ TableToColumns table )

@@ -482,7 +490,8 @@ DELETE statements

482490-- | Delete rows of a table.

483491deleteFrom

484492 :: ( SOP.SListI results

485− , Has sch db schema

493+ , db ~ (commons :=> schemas)

494+ , Has sch schemas schema

486495 , Has tab schema ('Table table)

487496 , row ~ TableToRow table

488497 , columns ~ TableToColumns table )

@@ -498,7 +507,8 @@ deleteFrom tab wh returning = UnsafeManipulation $

498507

499508-- | Delete rows returning `Nil`.

500509deleteFrom_

501− :: ( Has sch db schema

510+ :: ( db ~ (commons :=> schemas)

511+ , Has sch schemas schema

502512 , Has tab schema ('Table table)

503513 , row ~ TableToRow table

504514 , columns ~ TableToColumns table )

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+38−38

@@ -68,8 +68,8 @@ Now that we have a couple migrations we can chain them together.

6868>>> :{

6969let

7070 numMigrations

71− :: Has "migrations" db MigrationsSchema

72− => PQ db db IO ()

71+ :: Has "migrations" schemas MigrationsSchema

72+ => PQ schemas schemas IO ()

7373 numMigrations = do

7474 result <- runQuery (selectStar (from (table (#migrations ! #schema_migrations `as` #m))))

7575 num <- ntuples result

@@ -77,7 +77,7 @@ let

7777:}

7878

7979>>> :{

80−withConnection "host=localhost port=5432 dbname=exampledb" $

80+withConnection "host=localhost port=5432 schemasname=exampleschemas" $

8181 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

8282 -- suppress notices

8383 & pqThen (migrateUp migrations)

@@ -124,11 +124,11 @@ import Squeal.PostgreSQL

124124

125125-- | A `Migration` should contain an inverse pair of

126126-- `up` and `down` instructions and a unique `name`.

127−data Migration io db0 db1 = Migration

127+data Migration io schemas0 schemas1 = Migration

128128 { name :: Text -- ^ The `name` of a `Migration`.

129129 -- Each `name` in a `Migration` should be unique.

130− , up :: PQ db0 db1 io () -- ^ The `up` instruction of a `Migration`.

131− , down :: PQ db1 db0 io () -- ^ The `down` instruction of a `Migration`.

130+ , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.

131+ , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.

132132 }

133133

134134-- | Run `Migration`s by creating the `MigrationsTable`

@@ -137,10 +137,10 @@ data Migration io db0 db1 = Migration

137137-- execute the `Migration` and insert its row in the `MigrationsTable`.

138138migrateUp

139139 :: MonadBaseControl IO io

140− => AlignedList (Migration io) db0 db1 -- ^ migrations to run

140+ => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run

141141 -> PQ

142− ("migrations" ::: MigrationsSchema ': db0)

143− ("migrations" ::: MigrationsSchema ': db1)

142+ ("migrations" ::: MigrationsSchema ': schemas0)

143+ ("migrations" ::: MigrationsSchema ': schemas1)

144144 io ()

145145migrateUp migration =

146146 define createMigrations

@@ -150,10 +150,10 @@ migrateUp migration =

150150

151151 upMigrations

152152 :: MonadBaseControl IO io

153− => AlignedList (Migration io) db0 db1

153+ => AlignedList (Migration io) schemas0 schemas1

154154 -> PQ

155− ("migrations" ::: MigrationsSchema ': db0)

156− ("migrations" ::: MigrationsSchema ': db1)

155+ ("migrations" ::: MigrationsSchema ': schemas0)

156+ ("migrations" ::: MigrationsSchema ': schemas1)

157157 io ()

158158 upMigrations = \case

159159 Done -> return ()

@@ -161,9 +161,9 @@ migrateUp migration =

161161

162162 upMigration

163163 :: MonadBase IO io

164− => Migration io db0 db1 -> PQ

165− ("migrations" ::: MigrationsSchema ': db0)

166− ("migrations" ::: MigrationsSchema ': db1)

164+ => Migration io schemas0 schemas1 -> PQ

165+ ("migrations" ::: MigrationsSchema ': schemas0)

166+ ("migrations" ::: MigrationsSchema ': schemas1)

167167 io ()

168168 upMigration step =

169169 queryExecuted step

@@ -178,9 +178,9 @@ migrateUp migration =

178178

179179 queryExecuted

180180 :: MonadBase IO io

181− => Migration io db0 db1 -> PQ

182− ("migrations" ::: MigrationsSchema ': db0)

183− ("migrations" ::: MigrationsSchema ': db0)

181+ => Migration io schemas0 schemas1 -> PQ

182+ ("migrations" ::: MigrationsSchema ': schemas0)

183+ ("migrations" ::: MigrationsSchema ': schemas0)

184184 io Row

185185 queryExecuted step = do

186186 result <- runQueryParams selectMigration (Only (name step))

@@ -193,10 +193,10 @@ migrateUp migration =

193193-- rewind the `Migration` and delete its row in the `MigrationsTable`.

194194migrateDown

195195 :: MonadBaseControl IO io

196− => AlignedList (Migration io) db0 db1 -- ^ migrations to rewind

196+ => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind

197197 -> PQ

198− ("migrations" ::: MigrationsSchema ': db1)

199− ("migrations" ::: MigrationsSchema ': db0)

198+ ("migrations" ::: MigrationsSchema ': schemas1)

199+ ("migrations" ::: MigrationsSchema ': schemas0)

200200 io ()

201201migrateDown migrations =

202202 define createMigrations

@@ -206,9 +206,9 @@ migrateDown migrations =

206206

207207 downMigrations

208208 :: MonadBaseControl IO io

209− => AlignedList (Migration io) db0 db1 -> PQ

210− ("migrations" ::: MigrationsSchema ': db1)

211− ("migrations" ::: MigrationsSchema ': db0)

209+ => AlignedList (Migration io) schemas0 schemas1 -> PQ

210+ ("migrations" ::: MigrationsSchema ': schemas1)

211+ ("migrations" ::: MigrationsSchema ': schemas0)

212212 io ()

213213 downMigrations = \case

214214 Done -> return ()

@@ -216,9 +216,9 @@ migrateDown migrations =

216216

217217 downMigration

218218 :: MonadBase IO io

219− => Migration io db0 db1 -> PQ

220− ("migrations" ::: MigrationsSchema ': db1)

221− ("migrations" ::: MigrationsSchema ': db0)

219+ => Migration io schemas0 schemas1 -> PQ

220+ ("migrations" ::: MigrationsSchema ': schemas1)

221+ ("migrations" ::: MigrationsSchema ': schemas0)

222222 io ()

223223 downMigration step =

224224 queryExecuted step

@@ -233,9 +233,9 @@ migrateDown migrations =

233233

234234 queryExecuted

235235 :: MonadBase IO io

236− => Migration io db0 db1 -> PQ

237− ("migrations" ::: MigrationsSchema ': db1)

238− ("migrations" ::: MigrationsSchema ': db1)

236+ => Migration io schemas0 schemas1 -> PQ

237+ ("migrations" ::: MigrationsSchema ': schemas1)

238+ ("migrations" ::: MigrationsSchema ': schemas1)

239239 io Row

240240 queryExecuted step = do

241241 result <- runQueryParams selectMigration (Only (name step))

@@ -262,8 +262,8 @@ type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]

262262

263263-- | Creates a `MigrationsTable` if it does not already exist.

264264createMigrations

265− :: Has "migrations" db MigrationsSchema

266− => Definition db db

265+ :: Has "migrations" schemas MigrationsSchema

266+ => Definition schemas schemas

267267createMigrations =

268268 createSchemaIfNotExists #migrations >>>

269269 createTableIfNotExists (#migrations ! #schema_migrations)

@@ -274,23 +274,23 @@ createMigrations =

274274

275275-- | Inserts a `Migration` into the `MigrationsTable`

276276insertMigration

277− :: Has "migrations" db MigrationsSchema

278− => Manipulation db '[ 'NotNull 'PGtext] '[]

277+ :: Has "migrations" schemas MigrationsSchema

278+ => Manipulation ('[] :=> schemas) '[ 'NotNull 'PGtext] '[]

279279insertMigration = insertRow_ (#migrations ! #schema_migrations)

280280 ( Set (param @1) `as` #name :*

281281 Default `as` #executed_at )

282282

283283-- | Deletes a `Migration` from the `MigrationsTable`

284284deleteMigration

285− :: Has "migrations" db MigrationsSchema

286− => Manipulation db '[ 'NotNull 'PGtext ] '[]

285+ :: Has "migrations" schemas MigrationsSchema

286+ => Manipulation ('[] :=> schemas) '[ 'NotNull 'PGtext ] '[]

287287deleteMigration = deleteFrom_ (#migrations ! #schema_migrations) (#name .== param @1)

288288

289289-- | Selects a `Migration` from the `MigrationsTable`, returning

290290-- the time at which it was executed.

291291selectMigration

292− :: Has "migrations" db MigrationsSchema

293− => Query db '[ 'NotNull 'PGtext ]

292+ :: Has "migrations" schemas MigrationsSchema

293+ => Query ('[] :=> schemas) '[ 'NotNull 'PGtext ]

294294 '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]

295295selectMigration = select

296296 (#executed_at `as` #executed_at)

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+88−88

@@ -11,7 +11,7 @@ a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,

1111and a `PQ` type with instances for them.

1212

1313Using Squeal in your application will come down to defining

14−the @db@ of your database and including @PQ db db@ in your

14+the @schemas@ of your database and including @PQ schemas schemas@ in your

1515application's monad transformer stack, giving it an instance of `MonadPQ`.

1616

1717This module also provides functions for retrieving rows from the `LibPQ.Result`

@@ -124,28 +124,28 @@ To specify the schema you wish to connect with, use type application.

124124>>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]]

125125>>> :set -XTypeApplications

126126>>> :set -XOverloadedStrings

127−>>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"

127+>>> conn <- connectdbs @Schema "host=localhost port=5432 schemasname=exampleschemas"

128128

129129Note that, for now, squeal doesn't offer any protection from connecting

130130with the wrong schema!

131131-}

132132connectdb

133− :: forall db io

133+ :: forall schemas io

134134 . MonadBase IO io

135135 => ByteString -- ^ conninfo

136− -> io (K LibPQ.Connection db)

136+ -> io (K LibPQ.Connection schemas)

137137connectdb = fmap K . liftBase . LibPQ.connectdb

138138

139139-- | Closes the connection to the server.

140−finish :: MonadBase IO io => K LibPQ.Connection db -> io ()

140+finish :: MonadBase IO io => K LibPQ.Connection schemas -> io ()

141141finish = liftBase . LibPQ.finish . unK

142142

143−-- | Do `connectdb` and `finish` before and after a computation.

143+-- | Do `connectdbs` and `finish` before and after a computation.

144144withConnection

145− :: forall db0 db1 io x

145+ :: forall schemas0 schemas1 io x

146146 . MonadBaseControl IO io

147147 => ByteString

148− -> PQ db0 db1 io x

148+ -> PQ schemas0 schemas1 io x

149149 -> io x

150150withConnection connString action = do

151151 K x <- bracket (connectdb connString) finish (unPQ action)

@@ -153,20 +153,20 @@ withConnection connString action = do

153153

154154-- | Safely `lowerConnection` to a smaller schema.

155155lowerConnection

156− :: K LibPQ.Connection (schema ': db)

157− -> K LibPQ.Connection db

156+ :: K LibPQ.Connection (schema ': schemas)

157+ -> K LibPQ.Connection schemas

158158lowerConnection (K conn) = K conn

159159

160160-- | We keep track of the schema via an Atkey indexed state monad transformer,

161161-- `PQ`.

162162newtype PQ

163− (db0 :: DBType)

164− (db1 :: DBType)

163+ (schemas0 :: SchemasType)

164+ (schemas1 :: SchemasType)

165165 (m :: Type -> Type)

166166 (x :: Type) =

167− PQ { unPQ :: K LibPQ.Connection db0 -> m (K x db1) }

167+ PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }

168168

169−instance Monad m => Functor (PQ db0 db1 m) where

169+instance Monad m => Functor (PQ schemas0 schemas1 m) where

170170 fmap f (PQ pq) = PQ $ \ conn -> do

171171 K x <- pq conn

172172 return $ K (f x)

@@ -174,9 +174,9 @@ instance Monad m => Functor (PQ db0 db1 m) where

174174-- | Run a `PQ` and keep the result and the `Connection`.

175175runPQ

176176 :: Functor m

177− => PQ db0 db1 m x

178− -> K LibPQ.Connection db0

179− -> m (x, K LibPQ.Connection db1)

177+ => PQ schemas0 schemas1 m x

178+ -> K LibPQ.Connection schemas0

179+ -> m (x, K LibPQ.Connection schemas1)

180180runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

181181 -- K x <- pq conn

182182 -- return (x, K (unK conn))

@@ -184,16 +184,16 @@ runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

184184-- | Execute a `PQ` and discard the result but keep the `Connection`.

185185execPQ

186186 :: Functor m

187− => PQ db0 db1 m x

188− -> K LibPQ.Connection db0

189− -> m (K LibPQ.Connection db1)

187+ => PQ schemas0 schemas1 m x

188+ -> K LibPQ.Connection schemas0

189+ -> m (K LibPQ.Connection schemas1)

190190execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn

191191

192192-- | Evaluate a `PQ` and discard the `Connection` but keep the result.

193193evalPQ

194194 :: Functor m

195− => PQ db0 db1 m x

196− -> K LibPQ.Connection db0

195+ => PQ schemas0 schemas1 m x

196+ -> K LibPQ.Connection schemas0

197197 -> m x

198198evalPQ (PQ pq) conn = unK <$> pq conn

199199

@@ -208,53 +208,53 @@ class IndexedMonadTransPQ pq where

208208 -- | indexed analog of `<*>`

209209 pqAp

210210 :: Monad m

211− => pq db0 db1 m (x -> y)

212− -> pq db1 db2 m x

213− -> pq db0 db2 m y

211+ => pq schemas0 schemas1 m (x -> y)

212+ -> pq schemas1 schemas2 m x

213+ -> pq schemas0 schemas2 m y

214214

215215 -- | indexed analog of `join`

216216 pqJoin

217217 :: Monad m

218− => pq db0 db1 m (pq db1 db2 m y)

219− -> pq db0 db2 m y

218+ => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)

219+ -> pq schemas0 schemas2 m y

220220 pqJoin pq = pq & pqBind id

221221

222222 -- | indexed analog of `=<<`

223223 pqBind

224224 :: Monad m

225− => (x -> pq db1 db2 m y)

226− -> pq db0 db1 m x

227− -> pq db0 db2 m y

225+ => (x -> pq schemas1 schemas2 m y)

226+ -> pq schemas0 schemas1 m x

227+ -> pq schemas0 schemas2 m y

228228

229229 -- | indexed analog of flipped `>>`

230230 pqThen

231231 :: Monad m

232− => pq db1 db2 m y

233− -> pq db0 db1 m x

234− -> pq db0 db2 m y

232+ => pq schemas1 schemas2 m y

233+ -> pq schemas0 schemas1 m x

234+ -> pq schemas0 schemas2 m y

235235 pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

236236

237237 -- | indexed analog of `<=<`

238238 pqAndThen

239239 :: Monad m

240− => (y -> pq db1 db2 m z)

241− -> (x -> pq db0 db1 m y)

242− -> x -> pq db0 db2 m z

240+ => (y -> pq schemas1 schemas2 m z)

241+ -> (x -> pq schemas0 schemas1 m y)

242+ -> x -> pq schemas0 schemas2 m z

243243 pqAndThen g f x = pqBind g (f x)

244244

245245 -- | Safely embed a computation in a larger schema.

246246 pqEmbed

247247 :: Monad m

248− => pq db0 db1 m x

249− -> pq (schema ': db0) (schema : db1) m x

248+ => pq schemas0 schemas1 m x

249+ -> pq (schema ': schemas0) (schema : schemas1) m x

250250

251251 -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

252252 --

253253 -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

254254 define

255255 :: MonadBase IO io

256− => Definition db0 db1

257− -> pq db0 db1 io (K LibPQ.Result '[])

256+ => Definition schemas0 schemas1

257+ -> pq schemas0 schemas1 io (K LibPQ.Result '[])

258258

259259instance IndexedMonadTransPQ PQ where

260260

@@ -312,66 +312,66 @@ To define an instance, you can minimally define only `manipulateParams`,

312312a default instance.

313313

314314-}

315−class Monad pq => MonadPQ db pq | pq -> db where

315+class Monad pq => MonadPQ schemas pq | pq -> schemas where

316316 manipulateParams

317317 :: ToParams x params

318− => Manipulation db params ys

318+ => Manipulation ('[] :=> schemas) params ys

319319 -- ^ `insertRows`, `update` or `deleteFrom`

320320 -> x -> pq (K LibPQ.Result ys)

321321 default manipulateParams

322− :: (MonadTrans t, MonadPQ db pq1, pq ~ t pq1)

322+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

323323 => ToParams x params

324− => Manipulation db params ys

324+ => Manipulation ('[] :=> schemas) params ys

325325 -- ^ `insertRows`, `update` or `deleteFrom`

326326 -> x -> pq (K LibPQ.Result ys)

327327 manipulateParams manipulation params = lift $

328328 manipulateParams manipulation params

329329

330− manipulate :: Manipulation db '[] ys -> pq (K LibPQ.Result ys)

330+ manipulate :: Manipulation ('[] :=> schemas) '[] ys -> pq (K LibPQ.Result ys)

331331 manipulate statement = manipulateParams statement ()

332332

333333 runQueryParams

334334 :: ToParams x params

335− => Query db params ys

335+ => Query ('[] :=> schemas) params ys

336336 -- ^ `select` and friends

337337 -> x -> pq (K LibPQ.Result ys)

338338 runQueryParams = manipulateParams . queryStatement

339339

340340 runQuery

341− :: Query db '[] ys

341+ :: Query ('[] :=> schemas) '[] ys

342342 -- ^ `select` and friends

343343 -> pq (K LibPQ.Result ys)

344344 runQuery q = runQueryParams q ()

345345

346346 traversePrepared

347347 :: (ToParams x params, Traversable list)

348− => Manipulation db params ys

348+ => Manipulation ('[] :=> schemas) params ys

349349 -- ^ `insertRows`, `update`, or `deleteFrom`, and friends

350350 -> list x -> pq (list (K LibPQ.Result ys))

351351 default traversePrepared

352− :: (MonadTrans t, MonadPQ db pq1, pq ~ t pq1)

352+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

353353 => (ToParams x params, Traversable list)

354− => Manipulation db params ys -> list x -> pq (list (K LibPQ.Result ys))

354+ => Manipulation ('[] :=> schemas) params ys -> list x -> pq (list (K LibPQ.Result ys))

355355 traversePrepared manipulation params = lift $

356356 traversePrepared manipulation params

357357

358358 forPrepared

359359 :: (ToParams x params, Traversable list)

360360 => list x

361− -> Manipulation db params ys

361+ -> Manipulation ('[] :=> schemas) params ys

362362 -- ^ `insertRows`, `update` or `deleteFrom`

363363 -> pq (list (K LibPQ.Result ys))

364364 forPrepared = flip traversePrepared

365365

366366 traversePrepared_

367367 :: (ToParams x params, Foldable list)

368− => Manipulation db params '[]

368+ => Manipulation ('[] :=> schemas) params '[]

369369 -- ^ `insertRows`, `update` or `deleteFrom`

370370 -> list x -> pq ()

371371 default traversePrepared_

372− :: (MonadTrans t, MonadPQ db pq1, pq ~ t pq1)

372+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

373373 => (ToParams x params, Foldable list)

374− => Manipulation db params '[]

374+ => Manipulation ('[] :=> schemas) params '[]

375375 -- ^ `insertRows`, `update` or `deleteFrom`

376376 -> list x -> pq ()

377377 traversePrepared_ manipulation params = lift $

@@ -380,22 +380,22 @@ class Monad pq => MonadPQ db pq | pq -> db where

380380 forPrepared_

381381 :: (ToParams x params, Foldable list)

382382 => list x

383− -> Manipulation db params '[]

383+ -> Manipulation ('[] :=> schemas) params '[]

384384 -- ^ `insertRows`, `update` or `deleteFrom`

385385 -> pq ()

386386 forPrepared_ = flip traversePrepared_

387387

388388 liftPQ :: (LibPQ.Connection -> IO a) -> pq a

389389 default liftPQ

390− :: (MonadTrans t, MonadPQ db pq1, pq ~ t pq1)

390+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

391391 => (LibPQ.Connection -> IO a) -> pq a

392392 liftPQ = lift . liftPQ

393393

394−instance (MonadBase IO io, db0 ~ db, db1 ~ db)

395− => MonadPQ db (PQ db0 db1 io) where

394+instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)

395+ => MonadPQ schemas (PQ schemas0 schemas1 io) where

396396

397397 manipulateParams

398− (UnsafeManipulation q :: Manipulation db ps ys) (params :: x) =

398+ (UnsafeManipulation q :: Manipulation ('[] :=> schemas) ps ys) (params :: x) =

399399 PQ $ \ (K conn) -> do

400400 let

401401 toParam' encoding =

@@ -411,7 +411,7 @@ instance (MonadBase IO io, db0 ~ db, db1 ~ db)

411411 return $ K (K result)

412412

413413 traversePrepared

414− (UnsafeManipulation q :: Manipulation db xs ys) (list :: list x) =

414+ (UnsafeManipulation q :: Manipulation ('[] :=> schemas) xs ys) (list :: list x) =

415415 PQ $ \ (K conn) -> liftBase $ do

416416 let temp = "temporary_statement"

417417 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

@@ -438,7 +438,7 @@ instance (MonadBase IO io, db0 ~ db, db1 ~ db)

438438 return (K results)

439439

440440 traversePrepared_

441− (UnsafeManipulation q :: Manipulation db xs '[]) (list :: list x) =

441+ (UnsafeManipulation q :: Manipulation ('[] :=> schemas) xs '[]) (list :: list x) =

442442 PQ $ \ (K conn) -> liftBase $ do

443443 let temp = "temporary_statement"

444444 prepResultMaybe <- LibPQ.prepare conn temp q Nothing

@@ -466,56 +466,56 @@ instance (MonadBase IO io, db0 ~ db, db1 ~ db)

466466 y <- liftBase $ pq conn

467467 return (K y)

468468

469−instance MonadPQ db m => MonadPQ db (IdentityT m)

470−instance MonadPQ db m => MonadPQ db (ReaderT r m)

471−instance MonadPQ db m => MonadPQ db (Strict.StateT s m)

472−instance MonadPQ db m => MonadPQ db (Lazy.StateT s m)

473−instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.WriterT w m)

474−instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.WriterT w m)

475−instance MonadPQ db m => MonadPQ db (MaybeT m)

476−instance MonadPQ db m => MonadPQ db (ExceptT e m)

477−instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.RWST r w s m)

478−instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.RWST r w s m)

479−instance MonadPQ db m => MonadPQ db (ContT r m)

480−

481−instance (Monad m, db0 ~ db1)

482− => Applicative (PQ db0 db1 m) where

469+instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)

470+instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)

471+instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)

472+instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)

473+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)

474+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)

475+instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)

476+instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)

477+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)

478+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)

479+instance MonadPQ schemas m => MonadPQ schemas (ContT r m)

480+

481+instance (Monad m, schemas0 ~ schemas1)

482+ => Applicative (PQ schemas0 schemas1 m) where

483483 pure x = PQ $ \ _conn -> pure (K x)

484484 (<*>) = pqAp

485485

486−instance (Monad m, db0 ~ db1)

487− => Monad (PQ db0 db1 m) where

486+instance (Monad m, schemas0 ~ schemas1)

487+ => Monad (PQ schemas0 schemas1 m) where

488488 return = pure

489489 (>>=) = flip pqBind

490490

491−instance db0 ~ db1 => MFunctor (PQ db0 db1) where

491+instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where

492492 hoist f (PQ pq) = PQ (f . pq)

493493

494−instance db0 ~ db1 => MonadTrans (PQ db0 db1) where

494+instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where

495495 lift m = PQ $ \ _conn -> do

496496 x <- m

497497 return (K x)

498498

499−instance db0 ~ db1 => MMonad (PQ db0 db1) where

499+instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where

500500 embed f (PQ pq) = PQ $ \ conn -> do

501501 evalPQ (f (pq conn)) conn

502502

503−instance (MonadBase b m, db0 ~ db1)

504− => MonadBase b (PQ db0 db1 m) where

503+instance (MonadBase b m, schemas0 ~ schemas1)

504+ => MonadBase b (PQ schemas0 schemas1 m) where

505505 liftBase = lift . liftBase

506506

507507-- | A snapshot of the state of a `PQ` computation.

508−type PQRun db =

509− forall m x. Monad m => PQ db db m x -> m (K x db)

508+type PQRun schemas =

509+ forall m x. Monad m => PQ schemas schemas m x -> m (K x schemas)

510510

511511-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

512−pqliftWith :: Functor m => (PQRun db -> m a) -> PQ db db m a

512+pqliftWith :: Functor m => (PQRun schemas -> m a) -> PQ schemas schemas m a

513513pqliftWith f = PQ $ \ conn ->

514514 fmap K (f $ \ pq -> unPQ pq conn)

515515

516−instance (MonadBaseControl b m, db0 ~ db1)

517− => MonadBaseControl b (PQ db0 db1 m) where

518− type StM (PQ db0 db1 m) x = StM m (K x db0)

516+instance (MonadBaseControl b m, schemas0 ~ schemas1)

517+ => MonadBaseControl b (PQ schemas0 schemas1 m) where

518+ type StM (PQ schemas0 schemas1 m) x = StM m (K x schemas0)

519519 liftBaseWith f =

520520 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

521521 restoreM = PQ . const . restoreM

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+18−18

@@ -41,7 +41,7 @@ import Generics.SOP (K(..))

4141import Squeal.PostgreSQL.PQ

4242import Squeal.PostgreSQL.Schema

4343

44−{- | `PoolPQ` @db@ should be a drop-in replacement for `PQ` @db db@.

44+{- | `PoolPQ` @schemas@ should be a drop-in replacement for `PQ` @schemas schemas@.

4545

4646Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it.

4747

@@ -63,8 +63,8 @@ Here's a simplified example:

6363> liftIO $ runPoolPQ (insertOne) pool

6464

6565-}

66−newtype PoolPQ (db :: DBType) m x =

67− PoolPQ { runPoolPQ :: Pool (K Connection db) -> m x }

66+newtype PoolPQ (schemas :: SchemasType) m x =

67+ PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x }

6868 deriving Functor

6969

7070-- | Create a striped pool of connections.

@@ -86,12 +86,12 @@ createConnectionPool

8686 -> Int

8787 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.

8888 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.

89− -> io (Pool (K Connection db))

89+ -> io (Pool (K Connection schemas))

9090createConnectionPool conninfo stripes idle maxResrc = liftBase $

9191 createPool (connectdb conninfo) finish stripes idle maxResrc

9292

9393-- | `Applicative` instance for `PoolPQ`.

94−instance Monad m => Applicative (PoolPQ db m) where

94+instance Monad m => Applicative (PoolPQ schemas m) where

9595 pure x = PoolPQ $ \ _ -> pure x

9696 PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do

9797 f' <- f pool

@@ -99,55 +99,55 @@ instance Monad m => Applicative (PoolPQ db m) where

9999 return $ f' x'

100100

101101-- | `Monad` instance for `PoolPQ`.

102−instance Monad m => Monad (PoolPQ db m) where

102+instance Monad m => Monad (PoolPQ schemas m) where

103103 return = pure

104104 PoolPQ x >>= f = PoolPQ $ \ pool -> do

105105 x' <- x pool

106106 runPoolPQ (f x') pool

107107

108108-- | `MonadTrans` instance for `PoolPQ`.

109−instance MonadTrans (PoolPQ db) where

109+instance MonadTrans (PoolPQ schemas) where

110110 lift m = PoolPQ $ \ _pool -> m

111111

112112-- | `MonadBase` instance for `PoolPQ`.

113−instance MonadBase b m => MonadBase b (PoolPQ db m) where

113+instance MonadBase b m => MonadBase b (PoolPQ schemas m) where

114114 liftBase = lift . liftBase

115115

116116-- | `MonadPQ` instance for `PoolPQ`.

117−instance MonadBaseControl IO io => MonadPQ db (PoolPQ db io) where

117+instance MonadBaseControl IO io => MonadPQ schemas (PoolPQ schemas io) where

118118 manipulateParams manipulation params = PoolPQ $ \ pool -> do

119119 withResource pool $ \ conn -> do

120− (K result :: K (K Result ys) db) <- flip unPQ conn $

120+ (K result :: K (K Result ys) schemas) <- flip unPQ conn $

121121 manipulateParams manipulation params

122122 return result

123123 traversePrepared manipulation params = PoolPQ $ \ pool ->

124124 withResource pool $ \ conn -> do

125− (K result :: K (list (K Result ys)) db) <- flip unPQ conn $

125+ (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $

126126 traversePrepared manipulation params

127127 return result

128128 traversePrepared_ manipulation params = PoolPQ $ \ pool -> do

129129 withResource pool $ \ conn -> do

130− (_ :: K () db) <- flip unPQ conn $

130+ (_ :: K () schemas) <- flip unPQ conn $

131131 traversePrepared_ manipulation params

132132 return ()

133133 liftPQ m = PoolPQ $ \ pool ->

134134 withResource pool $ \ conn -> do

135− (K result :: K result db) <- flip unPQ conn $

135+ (K result :: K result schemas) <- flip unPQ conn $

136136 liftPQ m

137137 return result

138138

139139-- | A snapshot of the state of a `PoolPQ` computation.

140−type PoolPQRun db =

141− forall m x. Monad m => PoolPQ db m x -> m x

140+type PoolPQRun schemas =

141+ forall m x. Monad m => PoolPQ schemas m x -> m x

142142

143143-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.

144−poolpqliftWith :: Functor m => (PoolPQRun db -> m a) -> PoolPQ db m a

144+poolpqliftWith :: Functor m => (PoolPQRun schemas -> m a) -> PoolPQ schemas m a

145145poolpqliftWith f = PoolPQ $ \ pool ->

146146 (f $ \ pq -> runPoolPQ pq pool)

147147

148148-- | `MonadBaseControl` instance for `PoolPQ`.

149−instance MonadBaseControl b m => MonadBaseControl b (PoolPQ db m) where

150− type StM (PoolPQ db m) x = StM m x

149+instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schemas m) where

150+ type StM (PoolPQ schemas m) x = StM m x

151151 liftBaseWith f =

152152 poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

153153 restoreM = PoolPQ . const . restoreM

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+54−48

@@ -757,9 +757,9 @@ jsonbObjectKeys = unsafeSetOfFunction "jsonb_object_keys"

757757

758758unsafePopulateFunction

759759 :: ByteString

760− -> TypeExpression db (nullity ('PGcomposite row))

761− -> Expression db '[] 'Ungrouped params ty

762− -> Query db params row

760+ -> TypeExpression schemas (nullity ('PGcomposite row))

761+ -> Expression (commons :=> schemas) '[] 'Ungrouped params ty

762+ -> Query (commons :=> schemas) params row

763763unsafePopulateFunction fun ty expr = UnsafeQuery $

764764 "SELECT * FROM " <> fun <> "("

765765 <> "null::" <> renderTypeExpression ty <> ", "

@@ -768,42 +768,42 @@ unsafePopulateFunction fun ty expr = UnsafeQuery $

768768-- | Expands the JSON expression to a row whose columns match the record

769769-- type defined by the given table.

770770jsonPopulateRecord

771− :: TypeExpression db (nullity ('PGcomposite row)) -- ^ row type

772− -> Expression db '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object

773− -> Query db params row

771+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

772+ -> Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object

773+ -> Query (commons :=> schemas) params row

774774jsonPopulateRecord = unsafePopulateFunction "json_populate_record"

775775

776776-- | Expands the binary JSON expression to a row whose columns match the record

777777-- type defined by the given table.

778778jsonbPopulateRecord

779− :: TypeExpression db (nullity ('PGcomposite row)) -- ^ row type

780− -> Expression db '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object

781− -> Query db params row

779+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

780+ -> Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object

781+ -> Query (commons :=> schemas) params row

782782jsonbPopulateRecord = unsafePopulateFunction "jsonb_populate_record"

783783

784784-- | Expands the outermost array of objects in the given JSON expression to a

785785-- set of rows whose columns match the record type defined by the given table.

786786jsonPopulateRecordSet

787− :: TypeExpression db (nullity ('PGcomposite row)) -- ^ row type

788− -> Expression db '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array

789− -> Query db params row

787+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

788+ -> Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array

789+ -> Query (commons :=> schemas) params row

790790jsonPopulateRecordSet = unsafePopulateFunction "json_populate_record_set"

791791

792792-- | Expands the outermost array of objects in the given binary JSON expression

793793-- to a set of rows whose columns match the record type defined by the given

794794-- table.

795795jsonbPopulateRecordSet

796− :: TypeExpression db (nullity ('PGcomposite row)) -- ^ row type

797− -> Expression db '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array

798− -> Query db params row

796+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

797+ -> Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array

798+ -> Query (commons :=> schemas) params row

799799jsonbPopulateRecordSet = unsafePopulateFunction "jsonb_populate_record_set"

800800

801801unsafeRecordFunction

802802 :: (SListI record, json `In` PGJsonType)

803803 => ByteString

804− -> Expression db '[] 'Ungrouped params (nullity json)

805− -> NP (Aliased (TypeExpression db)) record

806− -> Query db params record

804+ -> Expression (commons :=> schemas) '[] 'Ungrouped params (nullity json)

805+ -> NP (Aliased (TypeExpression schemas)) record

806+ -> Query (commons :=> schemas) params record

807807unsafeRecordFunction fun expr types = UnsafeQuery $

808808 "SELECT * FROM " <> fun <> "("

809809 <> renderExpression expr <> ")"

@@ -816,33 +816,33 @@ unsafeRecordFunction fun expr types = UnsafeQuery $

816816-- | Builds an arbitrary record from a JSON object.

817817jsonToRecord

818818 :: SListI record

819− => Expression db '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object

820− -> NP (Aliased (TypeExpression db)) record -- ^ record types

821− -> Query db params record

819+ => Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object

820+ -> NP (Aliased (TypeExpression schemas)) record -- ^ record types

821+ -> Query (commons :=> schemas) params record

822822jsonToRecord = unsafeRecordFunction "json_to_record"

823823

824824-- | Builds an arbitrary record from a binary JSON object.

825825jsonbToRecord

826826 :: SListI record

827− => Expression db '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object

828− -> NP (Aliased (TypeExpression db)) record -- ^ record types

829− -> Query db params record

827+ => Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object

828+ -> NP (Aliased (TypeExpression schemas)) record -- ^ record types

829+ -> Query (commons :=> schemas) params record

830830jsonbToRecord = unsafeRecordFunction "jsonb_to_record"

831831

832832-- | Builds an arbitrary set of records from a JSON array of objects.

833833jsonToRecordSet

834834 :: SListI record

835− => Expression db '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array

836− -> NP (Aliased (TypeExpression db)) record -- ^ record types

837− -> Query db params record

835+ => Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array

836+ -> NP (Aliased (TypeExpression schemas)) record -- ^ record types

837+ -> Query (commons :=> schemas) params record

838838jsonToRecordSet = unsafeRecordFunction "json_to_record_set"

839839

840840-- | Builds an arbitrary set of records from a binary JSON array of objects.

841841jsonbToRecordSet

842842 :: SListI record

843− => Expression db '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array

844− -> NP (Aliased (TypeExpression db)) record -- ^ record types

845− -> Query db params record

843+ => Expression (commons :=> schemas) '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array

844+ -> NP (Aliased (TypeExpression schemas)) record -- ^ record types

845+ -> Query (commons :=> schemas) params record

846846jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"

847847

848848{-----------------------------------------

@@ -859,9 +859,9 @@ newtype FromClause db params from

859859

860860-- | A real `table` is a table from the database.

861861table

862− :: (Has sch db schema, Has tab schema ('Table table))

862+ :: (Has sch schemas schema, Has tab schema ('Table table))

863863 => Aliased (QualifiedAlias sch) (alias ::: tab)

864− -> FromClause db params '[alias ::: TableToRow table]

864+ -> FromClause (commons :=> schemas) params '[alias ::: TableToRow table]

865865table (tab `As` alias) = UnsafeFromClause $

866866 renderQualifiedAlias tab <+> "AS" <+> renderAlias alias

867867

@@ -873,9 +873,9 @@ subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)

873873

874874-- | `view` derives a table from a `View`.

875875view

876− :: (Has sch db schema, Has vw schema ('View view))

876+ :: (Has sch schemas schema, Has vw schema ('View view))

877877 => Aliased (QualifiedAlias sch) (alias ::: vw)

878− -> FromClause db params '[alias ::: view]

878+ -> FromClause (commons :=> schemas) params '[alias ::: view]

879879view (vw `As` alias) = UnsafeFromClause $

880880 renderQualifiedAlias vw <+> "AS" <+> renderAlias alias

881881

@@ -1365,18 +1365,25 @@ data CommonTableExpression statement

13651365 (db0 :: DBType)

13661366 (db1 :: DBType) where

13671367 CommonTableExpression

1368− :: ( Has "public" db schema

1369− , Alter "public" (alias ::: 'View cte ': schema) db ~ db1 )

1370− => Aliased (statement db params) (alias ::: cte)

1371− -> CommonTableExpression statement params db db1

1372−-- instance

1373−-- ( KnownSymbol vw

1374−-- , Has "public" db schema

1375−-- , Alter "public" (vw ::: 'View cte ': schema) db ~ db1

1376−-- ) => Aliasable vw

1377−-- (statement db params cte)

1378−-- (CommonTableExpression statement params db db1) where

1379−-- statement `as` vw = CommonTableExpression (statement `as` vw)

1368+ :: Aliased (statement (commons :=> schemas) params) (cte ::: common)

1369+ -> CommonTableExpression statement params

1370+ (commons :=> schemas) ((cte ::: common ': commons) :=> schemas)

1371+instance

1372+ ( KnownSymbol cte

1373+ , db0 ~ (commons :=> schemas)

1374+ , db1 ~ ((cte ::: common ': commons) :=> schemas)

1375+ ) => Aliasable cte

1376+ (statement db0 params common)

1377+ (CommonTableExpression statement params db0 db1) where

1378+ statement `as` cte = CommonTableExpression (statement `as` cte)

1379+instance

1380+ ( KnownSymbol cte

1381+ , db0 ~ (commons :=> schemas)

1382+ , db1 ~ ((cte ::: common ': commons) :=> schemas)

1383+ ) => Aliasable cte

1384+ (statement db0 params common)

1385+ (AlignedList (CommonTableExpression statement params) db0 db1) where

1386+ statement `as` cte = single (statement `as` cte)

13801387-- instance

13811388-- ( KnownSymbol vw

13821389-- , Has "public" db schema

@@ -1410,8 +1417,7 @@ renderCommonTableExpressions renderStatement cte ctes =

14101417-- defining temporary tables that exist just for one query.

14111418class With statement where

14121419 with

1413− :: Has "public" db0 schema0

1414− => AlignedList (CommonTableExpression statement params) db0 db1

1420+ :: AlignedList (CommonTableExpression statement params) db0 db1

14151421 -- ^ common table expressions

14161422 -> statement db1 params row

14171423 -- ^ larger query

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+4−1

@@ -54,6 +54,7 @@ module Squeal.PostgreSQL.Schema

5454 , TableType

5555 , SchemumType (..)

5656 , SchemaType

57+ , SchemasType

5758 , DBType

5859 -- * Constraints

5960 , (:=>)

@@ -683,7 +684,9 @@ type family Schema :: SchemaType where

683684-}

684685type SchemaType = [(Symbol,SchemumType)]

685686

686−type DBType = [(Symbol,SchemaType)]

687+type SchemasType = [(Symbol,SchemaType)]

688+

689+type DBType = (FromType,SchemasType)

687690

688691-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

689692-- the overloaded label, `fromLabel` is used for column references,

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+9−9

@@ -52,7 +52,7 @@ import Squeal.PostgreSQL.Schema

5252

5353-- | Run a schema invariant computation `transactionally`.

5454transactionally

55− :: (MonadBaseControl IO tx, MonadPQ db tx)

55+ :: (MonadBaseControl IO tx, MonadPQ schemas tx)

5656 => TransactionMode

5757 -> tx x -- ^ run inside a transaction

5858 -> tx x

@@ -64,30 +64,30 @@ transactionally mode tx = mask $ \restore -> do

6464

6565-- | Run a schema invariant computation `transactionally_` in `defaultMode`.

6666transactionally_

67− :: (MonadBaseControl IO tx, MonadPQ db tx)

67+ :: (MonadBaseControl IO tx, MonadPQ schemas tx)

6868 => tx x -- ^ run inside a transaction

6969 -> tx x

7070transactionally_ = transactionally defaultMode

7171

7272-- | @BEGIN@ a transaction.

73−begin :: MonadPQ db tx => TransactionMode -> tx (K Result ('[] :: RowType))

73+begin :: MonadPQ schemas tx => TransactionMode -> tx (K Result ('[] :: RowType))

7474begin mode = manipulate . UnsafeManipulation $

7575 "BEGIN" <+> renderTransactionMode mode <> ";"

7676

7777-- | @COMMIT@ a schema invariant transaction.

78−commit :: MonadPQ db tx => tx (K Result ('[] :: RowType))

78+commit :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))

7979commit = manipulate $ UnsafeManipulation "COMMIT;"

8080

8181-- | @ROLLBACK@ a schema invariant transaction.

82−rollback :: MonadPQ db tx => tx (K Result ('[] :: RowType))

82+rollback :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))

8383rollback = manipulate $ UnsafeManipulation "ROLLBACK;"

8484

8585-- | Run a schema changing computation `transactionallySchema`.

8686transactionallySchema

8787 :: MonadBaseControl IO io

8888 => TransactionMode

89− -> PQ db0 db1 io x

90− -> PQ db0 db1 io x

89+ -> PQ schemas0 schemas1 io x

90+ -> PQ schemas0 schemas1 io x

9191transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do

9292 _ <- liftBase . LibPQ.exec (unK conn) $

9393 "BEGIN" <+> renderTransactionMode mode <> ";"

@@ -99,8 +99,8 @@ transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do

9999-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.

100100transactionallySchema_

101101 :: MonadBaseControl IO io

102− => PQ db0 db1 io x

103− -> PQ db0 db1 io x

102+ => PQ schemas0 schemas1 io x

103+ -> PQ schemas0 schemas1 io x

104104transactionallySchema_ = transactionallySchema defaultMode

105105

106106-- | The available transaction characteristics are the transaction `IsolationLevel`,