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" />