4 files changed, 121 insertions, 0 deletions
diff --git a/lib/ddl/ast.ml b/lib/ddl/ast.ml
new file mode 100644
index 0000000..7faee40
--- /dev/null
+++ b/lib/ddl/ast.ml
@@ -0,0 +1,16 @@
+open Sexplib.Std
+
+type cardinality_spec =
+  | Finite of int
+  | AlephZero
+  | Continuum
+  | ConstrainedFinite
+[@@deriving sexp]
+
+type statement =
+  | CreateDatabase of string
+  | CreateRelation of { name: string; schema: (string * string) list }
+  | RetractRelation of string
+  | ClearRelation of string
+  | RegisterDomain of { name: string; cardinality: cardinality_spec }
+[@@deriving sexp]
diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml
new file mode 100644
index 0000000..fbb2f62
--- /dev/null
+++ b/lib/ddl/executor.ml
@@ -0,0 +1,68 @@
+module Make (Storage : Management.Physical.S) = struct
+  module Ops = Manipulation.Make(Storage)
+
+  type error =
+    | ParseError        of string
+    | ManipulationError of Manipulation.error
+    | RelationNotFound  of string
+
+  let sexp_of_error e =
+    let open Sexplib.Sexp in
+    match e with
+    | ParseError s        -> List [Atom "parse-error";        Atom s]
+    | ManipulationError e -> Manipulation.sexp_of_error e
+    | RelationNotFound s  -> List [Atom "relation-not-found"; Atom s]
+
+  let ( let* ) = Result.bind
+
+  let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r
+
+  let get_rel db name =
+    Ops.get_relation db ~name
+    |> Option.to_result ~none:(RelationNotFound name)
+
+  let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t = function
+    | Ast.Finite n          -> Conventions.Cardinality.Finite n
+    | Ast.AlephZero         -> Conventions.Cardinality.AlephZero
+    | Ast.Continuum         -> Conventions.Cardinality.Continuum
+    | Ast.ConstrainedFinite -> Conventions.Cardinality.ConstrainedFinite
+
+  let execute
+      (storage : Storage.t)
+      (db : Management.Database.t)
+      (stmt : Ast.statement)
+    : (Management.Database.t * string, error) result =
+    match stmt with
+    | Ast.CreateDatabase name ->
+      let* db = Ops.create_database storage ~name |> wrap_manip in
+      Ok (db, "Database created: " ^ name)
+
+    | Ast.CreateRelation { name; schema = schema_pairs } ->
+      let schema =
+        List.fold_left (fun s (attr, dom) -> Schema.add attr dom s) Schema.empty schema_pairs
+      in
+      let* (db, _) = Ops.create_relation storage db ~name ~schema |> wrap_manip in
+      Ok (db, "Relation created: " ^ name)
+
+    | Ast.RetractRelation name ->
+      let* db = Ops.retract_relation storage db ~name |> wrap_manip in
+      Ok (db, "Relation retracted: " ^ name)
+
+    | Ast.ClearRelation name ->
+      let* rel    = get_rel db name in
+      let* (db, _) = Ops.clear_relation storage db rel |> wrap_manip in
+      Ok (db, "Relation cleared: " ^ name)
+
+    | Ast.RegisterDomain { name; cardinality } ->
+      let domain = Domain.make
+        ~name
+        ~generator:(fun _ -> Generator.Error "not enumerable via DDL")
+        ~membership_criteria:(fun _ -> true)
+        ~cardinality:(convert_cardinality cardinality)
+        ~compare:Stdlib.compare
+      in
+      let* db = Ops.register_domain storage db domain |> wrap_manip in
+      Ok (db, "Domain registered: " ^ name)
+end
+
+module Memory = Make(Management.Physical.Memory)
diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml
new file mode 100644
index 0000000..28f8b6c
--- /dev/null
+++ b/lib/ddl/parser.ml
@@ -0,0 +1,14 @@
+type error = ParseError of string
+
+let of_sexp sexp =
+  match Ast.statement_of_sexp sexp with
+  | stmt          -> Ok stmt
+  | exception exn -> Error (ParseError (Printexc.to_string exn))
+
+let of_string s =
+  match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
+  | stmt          -> Ok stmt
+  | exception exn -> Error (ParseError (Printexc.to_string exn))
+
+let to_string stmt =
+  Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml
new file mode 100644
index 0000000..26a012f
--- /dev/null
+++ b/lib/ddl/sublanguage.ml
@@ -0,0 +1,23 @@
+module Make (Storage : Management.Physical.S) = struct
+  module Exec = Executor.Make(Storage)
+
+  type storage = Storage.t
+  type ast     = Ast.statement
+  type error   = Exec.error
+
+  let name = "ddl"
+
+  let parse_sexp sexp =
+    match Parser.of_sexp sexp with
+    | Ok r -> Ok r
+    | Error (Parser.ParseError s) -> Error (Exec.ParseError s)
+
+  let execute storage db ast =
+    match Exec.execute storage db ast with
+    | Ok (db, msg) -> Ok (Sublanguage.Transition (db, msg))
+    | Error e -> Error e
+
+  let sexp_of_error = Exec.sexp_of_error
+end
+
+module Memory = Make(Management.Physical.Memory)