experiment addition of schema support

src/Rezoom.SQL.Compiler/AST.fs

@@ -582,13 +582,17 @@ type [<NoComparison>] CreateTableDefinition<'t, 'e> =
 type [<NoComparison>] CreateTableAs<'t, 'e> =
  | CreateAsDefinition of CreateTableDefinition<'t, 'e>
  | CreateAsSelect of SelectStmt<'t, 'e>
-
+
 type [<NoComparison>] CreateTableStmt<'t, 'e> =
  { Temporary : bool
  Name : ObjectName<'t>
  As : CreateTableAs<'t, 'e>
  }
 
+type [<NoComparison>] CreateSchemaStmt<'t,'e> =
+ { SchemaName : Name 
+ }
+
 type [<NoComparison>] CreateIndexStmt<'t, 'e> =
  { Unique : bool
  IndexName : ObjectName<'t>
@@ -682,6 +686,7 @@ type [<NoComparison>] CreateViewStmt<'t, 'e> =
 
 type DropObjectType =
  | DropIndex
+ | DropSchema
  | DropTable
  | DropView
 
@@ -703,6 +708,7 @@ type [<NoComparison>] VendorStmt<'t, 'e> =
 and [<NoComparison>] Stmt<'t, 'e> =
  | AlterTableStmt of AlterTableStmt<'t, 'e>
  | CreateIndexStmt of CreateIndexStmt<'t, 'e>
+ | CreateSchemaStmt of CreateSchemaStmt<'t,'e>
  | CreateTableStmt of CreateTableStmt<'t, 'e>
  | CreateViewStmt of CreateViewStmt<'t, 'e>
  | DeleteStmt of DeleteStmt<'t, 'e>
@@ -746,6 +752,7 @@ type CompoundExpr = CompoundExpr<unit, unit>
 type CompoundTermCore = CompoundTermCore<unit, unit>
 type CompoundTerm = CompoundTerm<unit, unit>
 type CreateTableDefinition = CreateTableDefinition<unit, unit>
+type CreateSchemaStmt = CreateSchemaStmt<unit, unit>
 type CreateTableStmt = CreateTableStmt<unit, unit>
 type SelectCore = SelectCore<unit, unit>
 type Join = Join<unit, unit>

src/Rezoom.SQL.Compiler/ASTMapping.fs

@@ -12,6 +12,7 @@ type ASTMapping<'t1, 'e1, 't2, 'e2>(mapT : 't1 -> 't2, mapE : 'e1 -> 'e2) =
  { Operator = unary.Operator
  Operand = this.Expr(unary.Operand)
  }
+ member this.Name = Name
  member this.ObjectName(objectName : ObjectName<'t1>) =
  { SchemaName = objectName.SchemaName
  ObjectName = objectName.ObjectName
@@ -277,6 +278,10 @@ type ASTMapping<'t1, 'e1, 't2, 'e2>(mapT : 't1 -> 't2, mapE : 'e1 -> 'e2) =
  { Columns = createTable.Columns |> rmap this.ColumnDef
  Constraints = createTable.Constraints |> rmap this.TableConstraint
  }
+
+ member this.CreateSchema(createSchemaStmt: CreateSchemaStmt<'t1,'e1>) =
+ { SchemaName = createSchemaStmt.SchemaName
+ }
  member this.CreateTable(createTable : CreateTableStmt<'t1, 'e1>) =
  { Temporary = createTable.Temporary
  Name = this.ObjectName(createTable.Name)
@@ -327,6 +332,7 @@ type ASTMapping<'t1, 'e1, 't2, 'e2>(mapT : 't1 -> 't2, mapE : 'e1 -> 'e2) =
  Alteration = this.Alteration(alter.Alteration)
  }
  | CreateIndexStmt index -> CreateIndexStmt <| this.CreateIndex(index)
+ | CreateSchemaStmt createSchema -> CreateSchemaStmt <| this.CreateSchema(createSchema)
  | CreateTableStmt createTable -> CreateTableStmt <| this.CreateTable(createTable)
  | CreateViewStmt createView -> CreateViewStmt <| this.CreateView(createView)
  | DeleteStmt delete -> DeleteStmt <| this.Delete(delete)

src/Rezoom.SQL.Compiler/CommandEffect.fs

@@ -71,6 +71,7 @@ and private CommandEffectBuilder(model : Model) =
  match stmt with
  | AlterTableStmt { Alteration = AddColumn _ | AddConstraint _ | AddDefault _ }
  | CreateIndexStmt _
+ | CreateSchemaStmt _
  | CreateTableStmt _
  | SelectStmt _
  | CreateViewStmt _ -> false

src/Rezoom.SQL.Compiler/ComplexModelOps.fs

@@ -85,6 +85,11 @@ let addColumnDef tableName (column : ColumnDef<'t, 'e> WithSource) =
  do! ModelOps.addConstraint tableName constraintName constraintType cols
  }
 
+let createSchema schemaName (_def: CreateSchemaStmt<'t, 'e>) =
+ stateful {
+ do! ModelOps.putSchema schemaName
+ }
+
 let createTableByDefinition tableName (def : CreateTableDefinition<'t, 'e>) =
  stateful {
  do! ModelOps.createEmptyTable tableName

src/Rezoom.SQL.Compiler/CoreParser.fs

@@ -1006,13 +1006,21 @@ let private createTableDefinition =
  |> Seq.toArray
  }
 
+let private createSchemaStmt =
+ %% kw "CREATE"
+ -? kw "SCHEMA"
+ -- +.name
+ -|> fun name ->
+ { SchemaName = name
+ }
+
 let private createTableAs =
  %[ %% kw "AS" -- +.selectStmt -|> fun select _ -> CreateAsSelect select
  %% +.createTableDefinition -|> fun def tblName -> CreateAsDefinition (def tblName)
  ]
 
 let private temporary = %(zeroOrOne * [kw "TEMPORARY"; kw "TEMP"])
-
+
 let private createTableStmt =
  %% kw "CREATE"
  -- +.temporary
@@ -1164,6 +1172,7 @@ let private dropObjectType =
  %[ %% kw "INDEX" -|> DropIndex
  %% kw "TABLE" -|> DropTable
  %% kw "VIEW" -|> DropView
+ %% kw "SCHEMA" -|> DropSchema
  ]
 
 let private dropObjectStmt =
@@ -1186,6 +1195,7 @@ let private cteStmt =
 
 let coreStmt =
  %[ %% +.alterTableStmt -|> AlterTableStmt
+ %% +.createSchemaStmt -|> CreateSchemaStmt
  %% +.createIndexStmt -|> CreateIndexStmt
  %% +.createTableStmt -|> CreateTableStmt
  %% +.createViewStmt -|> CreateViewStmt

src/Rezoom.SQL.Compiler/DefaultStatementTranslator.fs

@@ -352,6 +352,14 @@ type DefaultStatementTranslator(expectedVendorName : Name, indexer : IParameterI
  let constraints = create.Constraints |> Seq.map (fun c -> this.TableConstraint(table, c.Value))
  yield! Seq.append columns constraints |> parencols
  }
+ override this.CreateSchema(create:TCreateSchemaStmt) =
+ seq {
+ yield text "CREATE"
+ yield ws
+ yield text "SCHEMA"
+ yield ws
+ yield this.Expr.Name(create.SchemaName)
+ }
  override this.CreateTable(create) =
  seq {
  yield text "CREATE"
@@ -485,6 +493,7 @@ type DefaultStatementTranslator(expectedVendorName : Name, indexer : IParameterI
  | DropIndex -> text "INDEX"
  | DropTable -> text "TABLE"
  | DropView -> text "VIEW"
+ | DropSchema -> text "SCHEMA"
  yield ws
  yield! this.Expr.ObjectName(drop.ObjectName)
  }
@@ -609,6 +618,7 @@ type DefaultStatementTranslator(expectedVendorName : Name, indexer : IParameterI
  override this.Statement(stmt) =
  match stmt with
  | AlterTableStmt alter -> this.AlterTable(alter)
+ | CreateSchemaStmt create -> this.CreateSchema(create)
  | CreateTableStmt create -> this.CreateTable(create)
  | CreateViewStmt create -> this.CreateView(create)
  | CreateIndexStmt create -> this.CreateIndex(create)

src/Rezoom.SQL.Compiler/Error.fs

@@ -158,4 +158,7 @@ let updateDuplicateColumn columnName =
  sprintf "SQ066: The column ``%O`` is specified multiple times in the update statement" columnName
 
 let tableNameNotSuitableForPG =
- "SQ069: Table name is not suitable for PG (maybe you thought you were writing R?)"
+ "SQ069: Table name is not suitable for PG (maybe you thought you were writing R?)"
+
+let cannotDropSchemaWithObjects schemaName objectNames =
+ sprintf "SQ070: Cannot drop the schema ``%O`` while it still contains object(s) (%O)" schemaName objectNames

src/Rezoom.SQL.Compiler/ExprInfo.fs

@@ -134,12 +134,14 @@ and [<NoComparison>]
 and [<NoComparison>]
  [<NoEquality>]
  ObjectInfo<'t> =
+ | Schema of Schema
  | TableLike of 't TableLikeExprInfo
  | Index of SchemaIndex
  | Missing
  member this.Idempotent =
  match this with
  | TableLike t -> t.Query.Idempotent
+ | Schema _
  | Index _
  | Missing -> true
  member this.Table =
@@ -153,7 +155,7 @@ and [<NoComparison>]
  | TableLike t -> TableLike (t.Map(f))
  | Index i -> Index i
  | Missing -> Missing
-
+ | Schema s -> Schema s
 
 and TSelectStmt = SelectStmt<ColumnType ObjectInfo, ColumnType ExprInfo>
 and TCreateViewStmt = CreateViewStmt<ColumnType ObjectInfo, ColumnType ExprInfo>
@@ -182,6 +184,7 @@ type TCompoundTerm = CompoundTerm<ColumnType ObjectInfo, ColumnType ExprInfo>
 type TForeignKeyClause = ForeignKeyClause<ColumnType ObjectInfo>
 type TCreateTableDefinition = CreateTableDefinition<ColumnType ObjectInfo, ColumnType ExprInfo>
 type TCreateTableStmt = CreateTableStmt<ColumnType ObjectInfo, ColumnType ExprInfo>
+type TCreateSchemaStmt = CreateSchemaStmt<ColumnType ObjectInfo, ColumnType ExprInfo>
 type TSelectCore = SelectCore<ColumnType ObjectInfo, ColumnType ExprInfo>
 type TJoinConstraint = JoinConstraint<ColumnType ObjectInfo, ColumnType ExprInfo>
 type TJoin = Join<ColumnType ObjectInfo, ColumnType ExprInfo>

src/Rezoom.SQL.Compiler/InferredTypes.fs

@@ -114,6 +114,7 @@ type InfCompoundExpr = CompoundExpr<InferredType ObjectInfo, InferredType ExprIn
 type InfCompoundTermCore = CompoundTermCore<InferredType ObjectInfo, InferredType ExprInfo>
 type InfCompoundTerm = CompoundTerm<InferredType ObjectInfo, InferredType ExprInfo>
 type InfCreateTableDefinition = CreateTableDefinition<InferredType ObjectInfo, InferredType ExprInfo>
+type InfCreateSchemaStmt = CreateSchemaStmt<InferredType ObjectInfo, InferredType ExprInfo>
 type InfCreateTableStmt = CreateTableStmt<InferredType ObjectInfo, InferredType ExprInfo>
 type InfSelectCore = SelectCore<InferredType ObjectInfo, InferredType ExprInfo>
 type InfJoinConstraint = JoinConstraint<InferredType ObjectInfo, InferredType ExprInfo>
@@ -264,6 +265,9 @@ and [<NoComparison>]
  ParentScope = Some this
  }
 
+ member private this.ResolveSchema
+ (schema : Schema) =
+ Found (ObjectInfo.Schema schema)
  member private this.ResolveObjectReferenceBySchema
  (schema : Schema, name : Name, inferView : CreateViewStmt -> TCreateViewStmt) =
  match schema.Objects |> Map.tryFind name with
@@ -280,6 +284,10 @@ and [<NoComparison>]
  /// Resolve a reference to a table which may occur as part of a TableExpr.
  /// This will resolve against the database model and CTEs, but not table aliases defined in the FROM clause.
  member this.ResolveObjectReference(name : ObjectName, inferView) =
+ match this.Model.Schema (Some name.ObjectName) with
+ | Some schema ->
+ this.ResolveSchema(schema)
+ | None ->
  match name.SchemaName with
  | None ->
  match this.CTEVariables.TryFind(name.ObjectName) with

src/Rezoom.SQL.Compiler/ModelChange.fs

@@ -4,6 +4,11 @@ open System.Collections.Generic
 open Rezoom.SQL.Compiler.InferredTypes
 
 type private ModelChange(model : Model, inference : ITypeInferenceContext) =
+ member private this.CreateSchema(create: InfCreateSchemaStmt) =
+ stateful {
+ let schema = { SchemaName = create.SchemaName; Objects = Map.empty }
+ return! ComplexModelOps.createSchema schema create
+ } |> State.runForOutputState model |> Some
  member private this.CreateTable(create : InfCreateTableStmt) =
  stateful {
  let! tableName = ComplexModelOps.qualifyTemp create.Temporary create.Name
@@ -64,6 +69,8 @@ type private ModelChange(model : Model, inference : ITypeInferenceContext) =
  return! ModelOps.dropView objName
  | DropTable ->
  return! ModelOps.dropTable objName
+ | DropSchema ->
+ return! ModelOps.dropSchema { Value = Some drop.ObjectName.ObjectName; Source = objName.Source }
  } |> State.runForOutputState model |> Some
  member this.CreateIndex(create : InfCreateIndexStmt) =
  stateful {
@@ -75,6 +82,7 @@ type private ModelChange(model : Model, inference : ITypeInferenceContext) =
  member this.Stmt(stmt : InfStmt) =
  match stmt with
  | AlterTableStmt alter -> this.AlterTable(alter)
+ | CreateSchemaStmt create -> this.CreateSchema(create)
  | CreateTableStmt create -> this.CreateTable(create)
  | CreateViewStmt create -> this.CreateView(create)
  | CreateIndexStmt create -> this.CreateIndex(create)

src/Rezoom.SQL.Compiler/ModelOps.fs

@@ -47,7 +47,6 @@ let getRequiredSchema (schemaName: Name option WithSource) =
 
 let getRequiredObject objectTypeName (name : QualifiedObjectName WithSource) =
  stateful {
- let! model = State.get
  let! schema = name.Map(fun n -> Some n.SchemaName) |> getRequiredSchema
  return
  match schema.Objects |> Map.tryFind name.Value.ObjectName with
@@ -88,10 +87,20 @@ let putSchema (schema : Schema) =
  return! State.put newModel
  }
 
+/// Remove an existing schema from the model.
+let removeSchema (schemaName : Name option WithSource) =
+ stateful {
+ let! model = State.get
+ let! schema = schemaName |> getRequiredSchema
+ if schema.Objects.Count > 0 then
+ failAt schemaName.Source <| Error.cannotDropSchemaWithObjects schema.SchemaName (schema.Objects |> Map.toArray |> Array.map (fun (k,_) -> k.Value) |> String.concat ", ")
+ let newModel = { model with Schemas = model.Schemas |> Map.remove schema.SchemaName }
+ return! State.put newModel
+ }
+
 /// Create or update an object within an existing schema in the model.
 let putObject (name : QualifiedObjectName WithSource) (obj : SchemaObject) =
  stateful {
- let! model = State.get
  let! schema = name.Map(fun n -> Some n.SchemaName) |> getRequiredSchema
  let newSchema = { schema with Objects = schema.Objects |> Map.add name.Value.ObjectName obj }
  return! putSchema newSchema
@@ -100,7 +109,6 @@ let putObject (name : QualifiedObjectName WithSource) (obj : SchemaObject) =
 /// Remove an existing object from the model.
 let removeObject (name : QualifiedObjectName WithSource) =
  stateful {
- let! model = State.get
  let! schema = name.Map(fun n -> Some n.SchemaName) |> getRequiredSchema
  let newSchema = { schema with Objects = schema.Objects |> Map.remove name.Value.ObjectName }
  return! putSchema newSchema
@@ -356,6 +364,13 @@ let dropView (viewName : QualifiedObjectName WithSource) =
  return! removeObject viewName
  }
 
+/// Remove an existing schema from the model.
+let dropSchema (schemaName : Name option WithSource) =
+ stateful {
+ let! _ = getRequiredSchema schemaName // ensure it exists
+ return! removeSchema schemaName
+ }
+
 /// Remove an existing index from the model.
 let dropIndex (indexName : QualifiedObjectName WithSource) =
  stateful {
@@ -367,7 +382,7 @@ let dropIndex (indexName : QualifiedObjectName WithSource) =
  return! removeObject indexName
  }
 
-/// Remove an existing table constraint from the mode.
+/// Remove an existing table constraint from the model.
 let dropConstraint (tableName : QualifiedObjectName WithSource) (constraintName : Name WithSource) =
  stateful {
  let! table = getRequiredTable tableName

src/Rezoom.SQL.Compiler/ReadWriteReferences.fs

@@ -195,6 +195,7 @@ type private ReferenceFinder(model : Model) =
  | UpdateStmt update -> this.Update(update)
  | AlterTableStmt _
  | CreateIndexStmt _
+ | CreateSchemaStmt _
  | CreateTableStmt _
  | CreateViewStmt _
  | DropObjectStmt _ -> ()

src/Rezoom.SQL.Compiler/TSQL.Statement.fs

@@ -28,6 +28,7 @@ type private TSQLStatement(indexer : IParameterIndexer) as this =
  | DropIndex -> text "INDEX"
  | DropTable -> text "TABLE"
  | DropView -> text "VIEW"
+ | DropSchema -> text "SCHEMA"
  yield ws
  yield! this.Expr.ObjectName(drop.ObjectName)
  match drop.Drop with

src/Rezoom.SQL.Compiler/Translators.fs

@@ -55,6 +55,7 @@ type StatementTranslator() =
  abstract member ColumnConstraint : table : TObjectName * constr : TColumnConstraint -> Fragments
  abstract member ColumnDefinition : table : TObjectName * col : TColumnDef -> Fragments
  abstract member CreateTableDefinition : table : TObjectName * create : TCreateTableDefinition -> Fragments
+ abstract member CreateSchema : create : TCreateSchemaStmt -> Fragments
  abstract member CreateTable : create : TCreateTableStmt -> Fragments
  abstract member AlterTable : alter : TAlterTableStmt -> Fragments
  abstract member CreateView : create : TCreateViewStmt -> Fragments

src/Rezoom.SQL.Compiler/TypeChecker.fs

@@ -634,6 +634,9 @@ type private TypeChecker(cxt : ITypeInferenceContext, scope : InferredSelectScop
  Constraints = createTable.Constraints |> rmap (fun con -> this.TableConstraint(con, creating))
  }
 
+ member this.CreateSchema(createSchema: CreateSchemaStmt) =
+ { SchemaName = createSchema.SchemaName }
+
  member this.CreateTable(createTable : CreateTableStmt) =
  let name = this.ObjectName(createTable.Name, true)
  let name =
@@ -775,7 +778,9 @@ type private TypeChecker(cxt : ITypeInferenceContext, scope : InferredSelectScop
  { Table = tbl
  Alteration = this.Alteration(tbl, alter.Alteration)
  }
+
  | CreateIndexStmt index -> CreateIndexStmt <| this.CreateIndex(index)
+ | CreateSchemaStmt createSchema -> CreateSchemaStmt <| this.CreateSchema(createSchema)
  | CreateTableStmt createTable -> CreateTableStmt <| this.CreateTable(createTable)
  | CreateViewStmt createView -> CreateViewStmt <| this.CreateView(createView)
  | DeleteStmt delete -> DeleteStmt <| this.Delete(delete)

src/Rezoom.SQL.Provider/DocStrings.fs

@@ -5,12 +5,14 @@ let private shortDescriptionCore (statement : Stmt<_, _>) =
  match statement with
  | AlterTableStmt _ -> "ALTER TABLE"
  | CreateIndexStmt _ -> "CREATE INDEX"
+ | CreateSchemaStmt _ -> "CREATE SCHEMA"
  | CreateTableStmt _ -> "CREATE TABLE"
  | CreateViewStmt _ -> "CREATE VIEW"
  | DeleteStmt _ -> "DELETE"
  | DropObjectStmt { Drop = DropIndex } -> "DROP INDEX"
  | DropObjectStmt { Drop = DropTable } -> "DROP TABLE"
  | DropObjectStmt { Drop = DropView } -> "DROP VIEW"
+ | DropObjectStmt { Drop = DropSchema } -> "DROP SCHEMA"
  | InsertStmt _ -> "INSERT"
  | SelectStmt _ -> "SELECT"
  | UpdateStmt _ -> "UPDATE"

src/Rezoom.SQL.Test/Rezoom.SQL.Test.fsproj

@@ -28,6 +28,7 @@
  <Compile Include="TestManyPrimitives.fs" />
  <Compile Include="TestQueryParents.fs" />
  <Compile Include="TestAlterTable.fs" />
+ <Compile Include="TestCreateSchema.fs" />
  <Compile Include="TestIdempotence.fs" />
  <Compile Include="TestReadWriteReferences.fs" />
  <Compile Include="TestCTEs.fs" />