Sublanguages improvement & Coq experiment (#53)

* separation and functor for sublanguages

* add coq experiment for termination

* fix tests with envelopes

* add timestamp and print responses to server on terminal

* remove coq experiment for trivial cases and rework gate

* refactor nesting with let*

* remove non-envelope sublang support and tests on server

* manip_err duplication purge and better format as s-expr

* abstract storage with dispatch for sublanguages

* dead code and minor refactor due to old non-envelope parsing on subl

* refactor server to use proper dml alg error and wire ephem relations

* remove (schema)

* change .gitignore to blacklist folders

1 files changed, 95 insertions, 241 deletions

diff --git a/bin/server.ml b/bin/server.ml
index 2c84468..80f392b 100644
--- a/bin/server.ml
+++ b/bin/server.ml
@@ -35,6 +35,7 @@ let materialize_relation storage (rel : Relation.t) limit =
 let short_hash (h : string) = String.sub h 0 (min 8 (String.length h))
 
 module BranchOps = Management.Branch.Make(Management.Physical.Memory)
+module Dispatch  = Dbms_language.Memory
 
 let get_branch storage =
   match BranchOps.get_head storage with
@@ -76,96 +77,45 @@ let ok_response storage db_name db_hash msg =
     List [Atom "branch";  Atom (get_branch storage)];
   ]
 
-let error_response storage db_name db_hash msg =
+let error_response storage db_name db_hash err_sexp =
   let open Sexplib.Sexp in
   to_string @@ List [
     Atom "error";
-    List [Atom "message"; Atom msg];
+    err_sexp;
     List [Atom "db_hash"; Atom (short_hash db_hash)];
     List [Atom "db_name"; Atom db_name];
     List [Atom "branch";  Atom (get_branch storage)];
   ]
 
-let manip_err = function
-  | Manipulation.RelationNotFound s      -> "RelationNotFound: " ^ s
-  | Manipulation.RelationAlreadyExists s -> "RelationAlreadyExists: " ^ s
-  | Manipulation.TupleNotFound h         -> "TupleNotFound: " ^ h
-  | Manipulation.DuplicateTuple h        -> "DuplicateTuple: " ^ h
-  | Manipulation.ConstraintViolation s   -> "ConstraintViolation: " ^ s
-  | Manipulation.StorageError s          -> "StorageError: " ^ s
-
-(* TODO: language dispatch by trying parsers in sequence is a code smell —
-   a valid DRL expression that happens to also parse as DML would silently
-   be treated as DRL. The three sublanguages should share a common envelope,
-   e.g. a top-level tag distinguishing (Query ...) from (Exec ...). *)
 let advance_head_branch storage new_hash =
   match BranchOps.get_head storage with
   | Ok (Some branch_name) ->
     ignore (BranchOps.update_tip storage ~name:branch_name ~tip:new_hash)
   | _ -> ()
 
+let dbms_dispatch = Dispatch.create [
+  (module Drl.Sublanguage.Memory : Dispatch.SubS);
+  (module Ddl.Sublanguage.Memory : Dispatch.SubS);
+  (module Dml.Sublanguage.Memory : Dispatch.SubS);
+  (module Icl.Sublanguage.Memory : Dispatch.SubS);
+  (module Dcl.Sublanguage.Memory : Dispatch.SubS);
+]
+
 let execute_command storage db_ref cmd =
   let db   = !db_ref in
   let h    = db.Management.Database.hash in
   let name = db.Management.Database.name in
   let ok   = ok_response    storage name in
   let err  = error_response storage name in
-  (* TODO: (schema) is a stopgap. Introspection should be expressible in
-     DRL itself via the catalog relations, not special-cased here. *)
-  let cmd = match String.trim cmd with
-    | "(schema)" -> {|(Base sakura:attribute)|}
-    | s -> s
-  in
-  match Drl.Parser.of_string cmd with
-  | Ok query ->
-    (match Drl.Executor.Memory.execute storage db query with
-     | Ok rel -> relation_to_sexp storage name h rel default_limit
-     | Error (Drl.Executor.Memory.RelationNotFound s) ->
-       err h ("RelationNotFound: " ^ s)
-     | Error (Drl.Executor.Memory.AlgebraError (Algebra.StorageError s)) ->
-       err h ("StorageError: " ^ s)
-     | Error (Drl.Executor.Memory.AlgebraError (Algebra.GeneratorError s)) ->
-       err h ("GeneratorError: " ^ s))
-  | Error _ ->
-    match Dml.Parser.of_string cmd with
-    | Ok stmt ->
-      (match Dml.Executor.Memory.execute storage db stmt with
-       | Ok new_db ->
-         db_ref := new_db;
-         advance_head_branch storage new_db.Management.Database.hash;
-         ok new_db.Management.Database.hash "updated"
-       | Error (Dml.Executor.Memory.ManipulationError me) ->
-         err h (manip_err me)
-       | Error (Dml.Executor.Memory.RelationNotFound s) ->
-         err h ("RelationNotFound: " ^ s)
-       | Error (Dml.Executor.Memory.ParseError s) ->
-         err h ("ParseError: " ^ s))
-    | Error _ ->
-      match Icl.Parser.of_string cmd with
-      | Ok stmt ->
-        (match Icl.Executor.Memory.execute storage db stmt with
-         | Ok (new_db, msg) ->
-           db_ref := new_db;
-           advance_head_branch storage new_db.Management.Database.hash;
-           ok new_db.Management.Database.hash msg
-         | Error (Icl.Executor.Memory.ManipulationError me) ->
-           err h (manip_err me)
-         | Error (Icl.Executor.Memory.ConversionError s) ->
-           err h ("ConversionError: " ^ s))
-      | Error _ ->
-        match Dcl.Parser.of_string cmd with
-        | Ok stmt ->
-          (match Dcl.Executor.Memory.execute storage db stmt with
-           | Ok (new_db, msg) ->
-             db_ref := new_db;
-             advance_head_branch storage new_db.Management.Database.hash;
-             ok new_db.Management.Database.hash msg
-           | Error (Dcl.Executor.Memory.BranchError s) ->
-             err h ("BranchError: " ^ s)
-           | Error (Dcl.Executor.Memory.MergeError s) ->
-             err h ("MergeError: " ^ s))
-        | Error _ ->
-          err h "ParseError: not valid DRL, DML, ICL, or DCL"
+  match Dispatch.execute dbms_dispatch storage db cmd with
+  | Ok (Sublanguage.Query rel) ->
+    relation_to_sexp storage name h rel default_limit
+  | Ok (Sublanguage.Transition (new_db, msg)) ->
+    db_ref := new_db;
+    advance_head_branch storage new_db.Management.Database.hash;
+    ok new_db.Management.Database.hash msg
+  | Error e ->
+    err h (Dispatch.sexp_of_dispatch_error e)
 
 (* TODO: registration failures are silently ignored; a broken prelude
    relation leaves the catalog in a partially-seeded state with no
@@ -184,7 +134,7 @@ let register_prelude_relations storage db =
       | Ok (new_db, _) -> new_db
       | Error e        ->
         Printf.eprintf "Warning: failed to register prelude relation %s: %s\n%!"
-          rel.name (manip_err e);
+          rel.name (Manipulation.string_of_error e);
         db)
     db
     [ less_than_natural
@@ -199,6 +149,18 @@ let register_prelude_relations storage db =
     ; divide_natural
     ]
 
+let print_with_time str =
+  let now = Unix.gettimeofday () in
+  let tm = Unix.localtime now in
+  let orange = "\027[38;5;208m" in
+  let reset = "\027[0m" in
+  let formatted_time = 
+    Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d"
+      (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
+      tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+  in 
+  print_endline @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str
+
 (* TODO: single-threaded accept loop — one slow or hung client blocks all
    others. Should use threads or non-blocking I/O. *)
 let handle_client storage db_ref fd =
@@ -215,183 +177,75 @@ let handle_client storage db_ref fd =
              let db = !db_ref in
              error_response storage db.Management.Database.name
                db.Management.Database.hash
-               ("Uncaught error: " ^ Printexc.to_string e)
+               Sexplib.Sexp.(List [Atom "uncaught-error"; Atom (Printexc.to_string e)])
          in
+         print_with_time response;
          output_string oc (response ^ "\n");
          flush oc
        end
      done
    with End_of_file | Unix.Unix_error _ -> ())
 
-let depart_emp = [
-    "(CreateRelation (name \"Department\") (schema ((dept_id \"integer\") (dept_name \"string\") (location \"string\"))))";
-    "(CreateRelation (name \"Employee\") (schema ((emp_id \"integer\") (emp_name \"string\") (salary \"float\") (dept_id \"integer\") (hire_date \"string\"))))";
-    "(RegisterConstraint(constraint_name \"salary_positive\")(relation_name \"Employee\")(body (MemberOf(target \"positive_reals\")(binding ((salary (Var \"salary\")))))))";
-    "(RegisterConstraint
-   (constraint_name \"fk_employee_dept\")
-   (relation_name \"Employee\")
-   (body (MemberOf
-     (target \"Department\")
-     (binding ((dept_id (Var \"dept_id\")))))))";
-    "(InsertTuple (relation \"Department\") (attributes ((dept_id (Int 1)) (location (Str \"Gifu\")) (dept_name (Str \"Nippon Ichi\")))))";
-    "(InsertTuples (relation \"Employee\") (tuples (((emp_id (Int 101)) (emp_name (Str \"Alice Johnson\")) (salary (Float 95000.0)) (dept_id (Int 1)) (hire_date (Str \"2020-01-15\"))))))"
-  ]
-
-let _depart_emp () =
-  match Management.Physical.Memory.create () with
-  | Error _ -> failwith "Failed to create storage"
-  | Ok storage ->
-    match Manipulation.Memory.create_database storage ~name:"sakura" with
-    | Error _ -> failwith "Failed to create initial database"
-    | Ok db ->
-      let db = register_prelude_relations storage db in
-      let db_ref = ref db in
-      Printf.printf "Database hash: %s\n%!" (short_hash db.Management.Database.hash);
-      List.iter (fun cmd -> print_endline @@ execute_command storage db_ref cmd)
-        depart_emp;
-      ()
-
-let n_way = [
-    "(CreateRelation
-  (name \"Building\")
-  (schema
-    ((building_id \"integer\")
-     (building_name \"string\")
-     (floors \"integer\"))))";
-    "(CreateRelation
-     (name \"Room\")
-  (schema
-    ((room_id \"integer\")
-     (building_id \"integer\")
-     (floor \"integer\")
-     (room_number \"string\"))))";
-"(CreateRelation
-  (name \"Suite\")
-  (schema
-    ((suite_id \"integer\")
-     (room_id \"integer\")
-     (suite_name \"string\")
- (capacity \"integer\"))))";
-(* FK: every Room must belong to an existing Building *)
-"(RegisterConstraint
-  (constraint_name \"fk_room_building\")
-  (relation_name \"Room\")
-  (body (MemberOf
-    (target \"Building\")
-    (binding ((building_id (Var \"building_id\")))))))";
-(* FK: every Suite must belong to an existing Room *)
-"(RegisterConstraint
-  (constraint_name \"fk_suite_room\")
-  (relation_name \"Suite\")
-  (body (MemberOf
-    (target \"Room\")
- (binding ((room_id (Var \"room_id\")))))))";
-(* A suite is only valid if its room belongs to a building with more than 3 floors *)
-"(RegisterConstraint
-  (constraint_name \"suite_in_tall_building\")
-  (relation_name \"Suite\")
-  (body
-    (Exists (variable \"r\") (quantifier \"Room\")
-      (body
-        (Exists (variable \"b\") (quantifier \"Building\")
-          (body
-            (And
-              ((MemberOf (target \"Room\")
-                 (binding ((room_id (Var \"room_id\")))))
-               (MemberOf (target \"Building\")
-                 (binding ((building_id (Var \"r.building_id\")))))
-               (MemberOf (target \"greater_than_natural\")
-                 (binding ((left (Var \"b.floors\")) (right (Const (Int 3))))))))))))))";
-"(InsertTuple
-  (relation \"Building\")
-  (attributes
-    ((building_id (Int 2))
-     (building_name (Str \"Tower B\"))
- (floors (Int 2)))))";
-    "(InsertTuple
-  (relation \"Building\")
-  (attributes
-    ((building_id (Int 1))
-     (building_name (Str \"Tower A\"))
-     (floors (Int 10)))))";
-"(InsertTuples
-  (relation \"Room\")
-  (tuples
-    (((room_id (Int 101)) (building_id (Int 1)) (floor (Int 1)) (room_number (Str \"1A\")))
-     ((room_id (Int 102)) (building_id (Int 1)) (floor (Int 2)) (room_number (Str \"2A\")))
- ((room_id (Int 201)) (building_id (Int 2)) (floor (Int 1)) (room_number (Str \"1B\"))))))";
-"(InsertTuples
-  (relation \"Suite\")
-  (tuples
-    (((suite_id (Int 1001)) (room_id (Int 101)) (suite_name (Str \"Presidential\")) (capacity (Int 4)))
-     ((suite_id (Int 1002)) (room_id (Int 101)) (suite_name (Str \"Standard\"))     (capacity (Int 2)))
-     ((suite_id (Int 1003)) (room_id (Int 102)) (suite_name (Str \"Deluxe\"))       (capacity (Int 3))))))";
-  ]
+let setup () =
+  let ( let* ) = Result.bind in
+  let* storage =
+    Management.Physical.Memory.create ()
+    |> Result.map_error (Fun.const "Failed to create storage")
+  in
+  let* db =
+    Manipulation.Memory.create_database storage ~name:"sakura"
+    |> Result.map_error (Fun.const "Failed to create initial database")
+  in
+  Ok (storage, db)
+
+let register_branch_relations storage db =
+  (* Register ephemeral sakura:branch and sakura:head relations backed by
+     the raw branch registry — no stored tuples, no circularity. *)
+  let register db rel =
+    match Manipulation.Memory.create_immutable_relation storage db
+            ~name:rel.Relation.name
+            ~schema:rel.Relation.schema
+            ~generator:(Option.get rel.Relation.generator)
+            ~membership_criteria:rel.Relation.membership_criteria
+            ~cardinality:rel.Relation.cardinality
+    with
+    | Ok (db, _) -> db
+    | Error e ->
+      Printf.eprintf "Warning: failed to register %s: %s\n%!"
+        rel.Relation.name (Manipulation.string_of_error e);
+      db
+  in
+  db
+  |> Fun.flip register (BranchOps.branch_relation storage)
+  |> Fun.flip register (BranchOps.head_relation storage)
 
-let _n_way () =
-  match Management.Physical.Memory.create () with
-  | Error _ -> failwith "Failed to create storage"
-  | Ok storage ->
-    match Manipulation.Memory.create_database storage ~name:"sakura" with
-    | Error _ -> failwith "Failed to create initial database"
-    | Ok db ->
-      let db = register_prelude_relations storage db in
-      let db_ref = ref db in
-      Printf.printf "Database hash: %s\n%!" (short_hash db.Management.Database.hash);
-      List.iter (fun cmd -> print_endline @@ execute_command storage db_ref cmd)
-        n_way;
-      ()
+let warn_on_error fmt = function
+  | Ok ()   -> ()
+  | Error e -> Printf.eprintf fmt e
 
 let () =
-  let port = default_port in
-  match Management.Physical.Memory.create () with
-  | Error _ -> failwith "Failed to create storage"
-  | Ok storage ->
-    match Manipulation.Memory.create_database storage ~name:"sakura" with
-    | Error _ -> failwith "Failed to create initial database"
-    | Ok db ->
-      let db = register_prelude_relations storage db in
-      (* Register ephemeral sakura:branch and sakura:head relations backed by
-         the raw branch registry — no stored tuples, no circularity. *)
-      let db =
-        let register db rel =
-          match Manipulation.Memory.create_immutable_relation storage db
-                  ~name:rel.Relation.name
-                  ~schema:rel.Relation.schema
-                  ~generator:(Option.get rel.Relation.generator)
-                  ~membership_criteria:rel.Relation.membership_criteria
-                  ~cardinality:rel.Relation.cardinality
-          with
-          | Ok (db, _) -> db
-          | Error e ->
-            Printf.eprintf "Warning: failed to register %s: %s\n%!"
-              rel.Relation.name (match e with
-                | Manipulation.RelationAlreadyExists s -> "already exists: " ^ s
-                | Manipulation.StorageError s -> s | _ -> "error");
-            db
-        in
-        let db = register db (BranchOps.branch_relation storage) in
-        let db = register db (BranchOps.head_relation storage) in
-        db
-      in
-      (* Create default master branch in raw registry and set HEAD *)
-      (match BranchOps.create storage ~name:"master"
-               ~tip:db.Management.Database.hash with
-       | Error e -> Printf.eprintf "Warning: failed to create master branch: %s\n%!" e
-       | Ok () -> ());
-      (match BranchOps.checkout storage "master" with
-       | Error e -> Printf.eprintf "Warning: failed to checkout master: %s\n%!" e
-       | Ok () -> ());
-      let db_ref = ref db in
-      let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
-      Unix.setsockopt sock Unix.SO_REUSEADDR true;
-      Unix.setsockopt sock Unix.SO_REUSEPORT true;
-      Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_loopback, port));
-      Unix.listen sock 5;
-      Printf.printf "Sakura server listening on 127.0.0.1:%d\n" port;
-      Printf.printf "Database hash: %s\n%!" (short_hash db.Management.Database.hash);
-      while true do
-        let (client_fd, _addr) = Unix.accept sock in
-        handle_client storage db_ref client_fd;
-        (try Unix.close client_fd with _ -> ())
-      done
+  match setup () with
+  | Error msg -> failwith msg
+  | Ok (storage, db) ->
+    let db = db
+      |> register_prelude_relations storage
+      |> register_branch_relations storage
+    in
+    (* Create default master branch in raw registry and set HEAD *)
+    BranchOps.create storage ~name:"master" ~tip:db.Management.Database.hash
+    |> warn_on_error "Warning: failed to create master branch: %s\n%!";
+    BranchOps.checkout storage "master"
+    |> warn_on_error "Warning: failed to checkout master: %s\n%!";
+    let db_ref = ref db in
+    let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+    Unix.setsockopt sock Unix.SO_REUSEADDR true;
+    Unix.setsockopt sock Unix.SO_REUSEPORT true;
+    Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_loopback, default_port));
+    Unix.listen sock 5;
+    Printf.printf "Sakura server listening on 127.0.0.1:%d\n" default_port;
+    Printf.printf "Database hash: %s\n%!" (short_hash db.Management.Database.hash);
+    while true do
+      let (client_fd, _addr) = Unix.accept sock in
+      handle_client storage db_ref client_fd;
+      (try Unix.close client_fd with _ -> ())
+    done