diff options
Diffstat (limited to '')
52 files changed, 5358 insertions, 4527 deletions
diff --git a/bin/bench.ml b/bin/bench.ml deleted file mode 100644 index 8f496f2..0000000 --- a/bin/bench.ml +++ /dev/null @@ -1,202 +0,0 @@ -open Relational_engine - -(* helpers *) - -let time label f = - let t0 = Unix.gettimeofday () in - f (); - let elapsed = Unix.gettimeofday () -. t0 in - Printf.printf " %-60s %.4f s\n%!" label elapsed - -let mk_int (n : int) : Conventions.AbstractValue.t = Obj.magic n - -let make_tuple relation pairs = - let attributes = - List.fold_left - (fun acc (k, v) -> - Tuple.AttributeMap.add k { Attribute.value = mk_int v } acc) - Tuple.AttributeMap.empty - pairs - in - { Tuple.relation; attributes } - -let unwrap label = function - | Ok v -> v - | Error _ -> failwith label - -let get_rel db name = - match Manipulation.Memory.get_relation db ~name with - | Some r -> r - | None -> failwith ("relation not found: " ^ name) - -(* database setup *) - -(* - Schema: - Department { dept_id } - Employee { emp_id, dept_id } - - Constraint on Employee: - Exists d in Department, MemberOf Department (dept_id = Var "dept_id") - - This is a classic FK: every employee must reference an existing department. - On the sublanguages branch, deleting a referenced Department triggers a - cascade re-check of affected Employee tuples and rejects the delete. - On master (no cascade), the delete succeeds unconditionally. -*) -let setup storage ~n_depts ~employees_per_dept = - let db = - unwrap "create_database" - (Manipulation.Memory.create_database storage ~name:"bench") - in - let db = - fst (unwrap "create Department" - (Manipulation.Memory.create_relation storage db ~name:"Department" - ~schema:(Schema.empty |> Schema.add "dept_id" "natural"))) - in - let db = - fst (unwrap "create Employee" - (Manipulation.Memory.create_relation storage db ~name:"Employee" - ~schema:(Schema.empty - |> Schema.add "emp_id" "natural" - |> Schema.add "dept_id" "natural"))) - in - let fk_body = - Constraint.Exists { - variable = "d"; - quantifier = "Department"; - body = Constraint.MemberOf { - target = "Department"; - binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id"); - }; - } - in - let db = - unwrap "register_constraint" - (Manipulation.Memory.register_constraint storage db - ~constraint_name:"fk_dept" - ~relation_name:"Employee" - ~body:fk_body) - in - let dept_tuples = - List.init n_depts (fun i -> - make_tuple "Department" [("dept_id", i + 1)]) - in - let db = - let (db, _, _) = unwrap "insert departments" - (Manipulation.Memory.create_tuples storage db - (get_rel db "Department") dept_tuples) - in db - in - let emp_tuples = - List.init (n_depts * employees_per_dept) (fun i -> - make_tuple "Employee" [ - ("emp_id", i + 1); - ("dept_id", (i mod n_depts) + 1); - ]) - in - let db = - let (db, _, _) = unwrap "insert employees" - (Manipulation.Memory.create_tuples storage db - (get_rel db "Employee") emp_tuples) - in db - in - db - -(* benchmark cases *) - -(* - Attempt to delete each department that has employees referencing it. - - sublanguages: retract_tuple runs the cascade check — uses polarity analysis - to identify Employee as the constrained relation, then focused_filter to - narrow the scan to only employees with dept_id = deleted dept_id. Finds a - match → returns ConstraintViolation. Delete is rejected. - - master: no cascade logic; retract_tuple succeeds unconditionally and db - becomes inconsistent. - - db is not threaded through since on sublanguages every delete is rejected - (db state is unchanged after each Error), and on master we deliberately - want to measure per-delete cost against a consistent employee set. -*) -let bench_retract_referenced storage db ~n_depts = - let rel = get_rel db "Department" in - for i = 1 to n_depts do - let hash = Hashing.hash_tuple (make_tuple "Department" [("dept_id", i)]) in - ignore (Manipulation.Memory.retract_tuple storage db rel ~tuple_hash:hash) - done - -(* - Delete departments that have NO referencing employees. Neither branch - needs to scan Employee tuples (focused_filter finds no matches), so this - measures raw retract_tuple cost: Merkle tree update + storage write. - - We thread db through the loop so each delete builds on the previous state - and only one live tree version accumulates in memory at a time. - - Orphan dept ids start at offset to avoid colliding with the employee-owned - depts (1..n_depts). -*) -let bench_retract_unreferenced storage db ~n_depts ~offset = - let orphan_tuples = - List.init n_depts (fun i -> - make_tuple "Department" [("dept_id", offset + i + 1)]) - in - let db = - let (db, _, _) = unwrap "insert orphan depts" - (Manipulation.Memory.create_tuples storage db - (get_rel db "Department") orphan_tuples) - in db - in - let _db = - List.fold_left (fun db i -> - let rel = get_rel db "Department" in - let hash = Hashing.hash_tuple (make_tuple "Department" [("dept_id", offset + i)]) in - match Manipulation.Memory.retract_tuple storage db rel ~tuple_hash:hash with - | Ok (db, _) -> db - | Error _ -> db) - db - (List.init n_depts (fun i -> i + 1)) - in - () - -(* entry point *) - -let () = - let n_depts = 100 in - let employees_per_dept = 200 in - let total_employees = n_depts * employees_per_dept in - - Printf.printf "\nSakura constraint benchmark\n"; - Printf.printf " Departments : %d\n" n_depts; - Printf.printf " Employees/dept : %d (%d total)\n\n" - employees_per_dept total_employees; - - let make_storage () = - match Management.Physical.Memory.create () with - | Ok s -> s - | Error _ -> failwith "create storage" - in - - (* Warmup build — not measured *) - let storage = make_storage () in - ignore (setup storage ~n_depts ~employees_per_dept); - - (* Fresh storage for measured runs *) - let storage = make_storage () in - let db = setup storage ~n_depts ~employees_per_dept in - - Printf.printf "Scenarios:\n"; - - time (Printf.sprintf - "retract %d referenced depts (cascade check, violations expected)" - n_depts) - (fun () -> bench_retract_referenced storage db ~n_depts); - - time (Printf.sprintf - "retract %d unreferenced depts (no matching employees)" - n_depts) - (fun () -> bench_retract_unreferenced storage db ~n_depts ~offset:1_000_000); - - Printf.printf "\n" diff --git a/bin/main.ml b/bin/main.ml index 46bb9f1..c77d756 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,11 +1,17 @@ let main () = - let digest = Relational_engine.Interop.Sha256.compute_hash (Bytes.of_string "sakura") in + let digest = + Relational_engine.Interop.Sha256.compute_hash (Bytes.of_string "sakura") + in print_endline digest let () = - let tuple = - Relational_engine.Tuple.make_materialized - ~relation: "natural_less_than" - ~attributes: (Relational_engine.Tuple.AttributeMap.of_list [("left", Obj.magic 0); ("right", Obj.magic 1)]) - in print_endline @@ string_of_bool @@ Relational_engine.Prelude.Standard.less_than_natural.membership_criteria tuple; + let tuple = + Relational_engine.Tuple.make_materialized ~relation:"natural_less_than" + ~attributes: + (Relational_engine.Tuple.AttributeMap.of_list + [ ("left", Obj.magic 0); ("right", Obj.magic 1) ]) + in + print_endline @@ string_of_bool + @@ Relational_engine.Prelude.Standard.less_than_natural.membership_criteria + tuple; main () diff --git a/bin/server.ml b/bin/server.ml index 2b9e651..82965dc 100644 --- a/bin/server.ml +++ b/bin/server.ml @@ -15,16 +15,17 @@ let materialize_generator gen limit = if count >= limit then (List.rev acc, true) else match gen (Some pos) with - | Generator.Done -> (List.rev acc, false) - | Generator.Error _ -> (List.rev acc, false) - | Generator.Value (t, next) -> - let mat = match t with - | Tuple.Materialized m -> Some m - | Tuple.NonMaterialized _ -> None - in - (match mat with - | None -> go next (pos + 1) acc count - | Some m -> go next (pos + 1) (m :: acc) (count + 1)) + | Generator.Done -> (List.rev acc, false) + | Generator.Error _ -> (List.rev acc, false) + | Generator.Value (t, next) -> ( + let mat = + match t with + | Tuple.Materialized m -> Some m + | Tuple.NonMaterialized _ -> None + in + match mat with + | None -> go next (pos + 1) acc count + | Some m -> go next (pos + 1) (m :: acc) (count + 1)) in go gen 0 [] 0 @@ -34,106 +35,116 @@ 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 +module BranchOps = Management.Branch.Make (Management.Physical.Memory) +module Dispatch = Dbms_language.Memory let get_branch storage = - match BranchOps.get_head storage with - | Ok (Some name) -> name - | _ -> "--" + match BranchOps.get_head storage with Ok (Some name) -> name | _ -> "--" let tuple_to_sexp (t : Tuple.materialized) = let open Sexplib.Sexp in - List (Tuple.AttributeMap.bindings t.Tuple.attributes - |> List.map (fun (k, attr) -> - List [Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value])) + List + (Tuple.AttributeMap.bindings t.Tuple.attributes + |> List.map (fun (k, attr) -> + List + [ Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value ]) + ) let relation_to_sexp storage db_name db_hash (rel : Relation.t) limit = let open Sexplib.Sexp in let schema_sexp = - List (List.map (fun (a, d) -> List [Atom a; Atom d]) rel.Relation.schema) + List (List.map (fun (a, d) -> List [ Atom a; Atom d ]) rel.Relation.schema) in - let (tuples, truncated) = materialize_relation storage rel limit in + let tuples, truncated = materialize_relation storage rel limit in let rows_sexp = List (List.map tuple_to_sexp tuples) in - to_string @@ List [ - Atom "relation"; - List [Atom "name"; Atom rel.Relation.name]; - List [Atom "schema"; schema_sexp]; - List [Atom "rows"; rows_sexp]; - List [Atom "row_count"; Atom (string_of_int (List.length tuples))]; - List [Atom "truncated"; Atom (string_of_bool truncated)]; - List [Atom "db_hash"; Atom (short_hash db_hash)]; - List [Atom "db_name"; Atom db_name]; - List [Atom "branch"; Atom (get_branch storage)]; - ] + to_string + @@ List + [ + Atom "relation"; + List [ Atom "name"; Atom rel.Relation.name ]; + List [ Atom "schema"; schema_sexp ]; + List [ Atom "rows"; rows_sexp ]; + List [ Atom "row_count"; Atom (string_of_int (List.length tuples)) ]; + List [ Atom "truncated"; Atom (string_of_bool truncated) ]; + List [ Atom "db_hash"; Atom (short_hash db_hash) ]; + List [ Atom "db_name"; Atom db_name ]; + List [ Atom "branch"; Atom (get_branch storage) ]; + ] let ok_response storage db_name db_hash msg = let open Sexplib.Sexp in - to_string @@ List [ - Atom "ok"; - List [Atom "message"; Atom msg]; - List [Atom "db_hash"; Atom (short_hash db_hash)]; - List [Atom "db_name"; Atom db_name]; - List [Atom "branch"; Atom (get_branch storage)]; - ] + to_string + @@ List + [ + Atom "ok"; + List [ Atom "message"; Atom msg ]; + List [ Atom "db_hash"; Atom (short_hash db_hash) ]; + List [ Atom "db_name"; Atom db_name ]; + List [ Atom "branch"; Atom (get_branch storage) ]; + ] let error_response storage db_name db_hash err_sexp = let open Sexplib.Sexp in - to_string @@ List [ - Atom "error"; - 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)]; - ] + to_string + @@ List + [ + Atom "error"; + 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 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) + 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); - (module Scl.Sublanguage.Memory : Dispatch.SubS); -] +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); + (module Scl.Sublanguage.Memory : Dispatch.SubS); + ] let cursor_to_sexp storage db_name db_hash cursor_id rows has_more = let open Sexplib.Sexp in let row_sexps = List.map tuple_to_sexp rows in let rows_sexp = List row_sexps in - to_string @@ List [ - Atom "cursor"; - List [Atom "id"; Atom cursor_id]; - List [Atom "rows"; rows_sexp]; - List [Atom "row_count"; Atom (string_of_int (List.length row_sexps))]; - List [Atom "has_more"; Atom (string_of_bool has_more)]; - List [Atom "db_hash"; Atom (short_hash db_hash)]; - List [Atom "db_name"; Atom db_name]; - List [Atom "branch"; Atom (get_branch storage)]; - ] + to_string + @@ List + [ + Atom "cursor"; + List [ Atom "id"; Atom cursor_id ]; + List [ Atom "rows"; rows_sexp ]; + List [ Atom "row_count"; Atom (string_of_int (List.length row_sexps)) ]; + List [ Atom "has_more"; Atom (string_of_bool has_more) ]; + List [ Atom "db_hash"; Atom (short_hash db_hash) ]; + List [ Atom "db_name"; Atom db_name ]; + List [ Atom "branch"; Atom (get_branch storage) ]; + ] let execute_command storage db_ref cmd = - let db = !db_ref in - let h = db.Management.Database.hash in + 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 + let ok = ok_response storage name in + let err = error_response storage name in match Dispatch.execute dbms_dispatch storage db cmd with | Ok (Sublanguage.Query rel) -> - relation_to_sexp storage name h rel default_limit + 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 + db_ref := new_db; + advance_head_branch storage new_db.Management.Database.hash; + ok new_db.Management.Database.hash msg | Ok (Sublanguage.Cursor { cursor_id; rows; has_more }) -> - cursor_to_sexp storage name h cursor_id rows has_more - | Error e -> - err h (Dispatch.sexp_of_dispatch_error e) + cursor_to_sexp storage name h cursor_id rows has_more + | 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 @@ -142,29 +153,30 @@ let register_prelude_relations storage db = let open Prelude.Standard in List.fold_left (fun db (rel : Relation.t) -> - match Manipulation.Memory.create_immutable_relation storage db - ~name:rel.name - ~schema:rel.schema - ~generator:(Option.get rel.generator) - ~membership_criteria:rel.membership_criteria - ~cardinality:rel.cardinality + match + Manipulation.Memory.create_immutable_relation storage db ~name:rel.name + ~schema:rel.schema ~generator:(Option.get rel.generator) + ~membership_criteria:rel.membership_criteria + ~cardinality:rel.cardinality with | Ok (new_db, _) -> new_db - | Error e -> - Printf.eprintf "Warning: failed to register prelude relation %s: %s\n%!" - rel.name (Manipulation.string_of_error e); - db) + | Error e -> + Printf.eprintf + "Warning: failed to register prelude relation %s: %s\n%!" rel.name + (Manipulation.string_of_error e); + db) db - [ less_than_natural - ; less_than_or_equal_natural - ; greater_than_natural - ; greater_than_or_equal_natural - ; equal_natural - ; not_equal_natural - ; plus_natural - ; times_natural - ; minus_natural - ; divide_natural + [ + less_than_natural; + less_than_or_equal_natural; + greater_than_natural; + greater_than_or_equal_natural; + equal_natural; + not_equal_natural; + plus_natural; + times_natural; + minus_natural; + divide_natural; ] let print_with_time str = @@ -173,9 +185,9 @@ let print_with_time str = 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 + 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 @@ -184,25 +196,26 @@ let print_with_time str = let handle_client storage db_ref fd = let ic = Unix.in_channel_of_descr fd in let oc = Unix.out_channel_of_descr fd in - (try - while true do - let line = input_line ic in - let line = String.trim line in - if line <> "" then begin - let response = - try execute_command storage db_ref line - with e -> - let db = !db_ref in - error_response storage db.Management.Database.name - db.Management.Database.hash - 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 _ -> ()) + try + while true do + let line = input_line ic in + let line = String.trim line in + if line <> "" then begin + let response = + try execute_command storage db_ref line + with e -> + let db = !db_ref in + error_response storage db.Management.Database.name + db.Management.Database.hash + 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 setup () = let ( let* ) = Result.bind in @@ -220,62 +233,62 @@ 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 + 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 + 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 warn_on_error fmt = function - | Ok () -> () - | Error e -> Printf.eprintf fmt e - -let cursor_gc_max_age = 300.0 (* 5 minutes *) -let cursor_gc_interval = 60.0 (* run GC at most once per minute *) +let warn_on_error fmt = function Ok () -> () | Error e -> Printf.eprintf fmt e +let cursor_gc_max_age = 300.0 (* 5 minutes *) +let cursor_gc_interval = 60.0 (* run GC at most once per minute *) let () = match setup () with | Error msg -> failwith msg | Ok (storage, db) -> - let db = db - |> register_prelude_relations storage - |> register_branch_relations storage - in - (* Initialise cursor session registry for SCL *) - let session_reg = Session.create () in - Scl.Executor.set_sessions session_reg; - (* 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 last_gc = ref 0.0 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 _ -> ()); - let now = Unix.gettimeofday () in - if now -. !last_gc >= cursor_gc_interval then begin - Session.gc session_reg ~max_age:cursor_gc_max_age; - last_gc := now - end - done + let db = + db + |> register_prelude_relations storage + |> register_branch_relations storage + in + (* Initialise cursor session registry for SCL *) + let session_reg = Session.create () in + Scl.Executor.set_sessions session_reg; + (* 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 last_gc = ref 0.0 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 _ -> ()); + let now = Unix.gettimeofday () in + if now -. !last_gc >= cursor_gc_interval then begin + Session.gc session_reg ~max_age:cursor_gc_max_age; + last_gc := now + end + done diff --git a/lib/algebra.ml b/lib/algebra.ml index a1970bd..30ed1a6 100644 --- a/lib/algebra.ml +++ b/lib/algebra.ml @@ -1,39 +1,40 @@ -type error = - | StorageError of string - | GeneratorError of string +type error = StorageError of string | GeneratorError of string + +module Make (Storage : Management.Physical.S) = struct + module Ops = Manipulation.Make (Storage) -module Make(Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) type storage = Storage.t (* Internal generator utilities *) let rec list_generator : Tuple.t list -> Generator.t = function - | [] -> (fun _pos -> Generator.Done) - | t :: rest -> (fun _pos -> Generator.Value (t, list_generator rest)) + | [] -> fun _pos -> Generator.Done + | t :: rest -> fun _pos -> Generator.Value (t, list_generator rest) let drain gen = let rec go gen pos acc = match gen (Some pos) with - | Generator.Done -> Ok (List.rev acc) - | Generator.Error e -> Error (GeneratorError e) + | Generator.Done -> Ok (List.rev acc) + | Generator.Error e -> Error (GeneratorError e) | Generator.Value (t, next) -> go next (pos + 1) (t :: acc) - in go gen 0 [] + in + go gen 0 [] let to_generator (storage : storage) (rel : Relation.t) : Generator.t = match rel.Relation.generator with | Some gen -> gen - | None -> - (* TODO: Avoid materializing all tuple hashes/tuples at once. + | None -> ( + (* TODO: Avoid materializing all tuple hashes/tuples at once. Current implementation calls tuple_hashes rel which loads all hashes into memory, then load_tuples which loads all tuples. This defeats lazy evaluation and scales badly (fails for billions of tuples). Replace with paginated tuple_hashes or Merkle streaming to load hashes/tuples on demand in chunks. *) - let hashes = Ops.tuple_hashes rel in - (match Ops.load_tuples storage hashes with - | Error _ -> (fun _pos -> Generator.Error ("Failed to load: " ^ rel.Relation.name)) - | Ok ts -> list_generator (List.map (fun t -> Tuple.Materialized t) ts)) + let hashes = Ops.tuple_hashes rel in + match Ops.load_tuples storage hashes with + | Error _ -> + fun _pos -> Generator.Error ("Failed to load: " ^ rel.Relation.name) + | Ok ts -> list_generator (List.map (fun t -> Tuple.Materialized t) ts)) let of_generator ~name ~schema ?constraints ?cardinality gen = let cardinality = @@ -41,22 +42,24 @@ module Make(Storage : Management.Physical.S) = struct | Some c -> c | None -> Conventions.Cardinality.AlephZero in - Relation.make - ~hash:None ~name ~schema ~tree:None ~constraints - ~cardinality + Relation.make ~hash:None ~name ~schema ~tree:None ~constraints ~cardinality ~generator:(Some gen) ~membership_criteria:(fun _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "derived") - let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : Relation.t = - let attrs = List.fold_left (fun acc (k, v) -> - Tuple.AttributeMap.add k { Attribute.value = v } acc) - Tuple.AttributeMap.empty pairs + let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : + Relation.t = + let attrs = + List.fold_left + (fun acc (k, v) -> Tuple.AttributeMap.add k { Attribute.value = v } acc) + Tuple.AttributeMap.empty pairs + in + let tuple = + Tuple.Materialized { Tuple.relation = "const"; attributes = attrs } in - let tuple = Tuple.Materialized { Tuple.relation = "const"; attributes = attrs } in let schema = List.map (fun (k, _) -> (k, "abstract")) pairs in - of_generator ~name:"const" ~schema (list_generator [tuple]) + of_generator ~name:"const" ~schema (list_generator [ tuple ]) (* Operators *) @@ -65,141 +68,181 @@ module Make(Storage : Management.Physical.S) = struct let lazy_gen = let rec go g pos = match g pos with - | Generator.Done -> Generator.Done + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> - if predicate t then Generator.Value (t, go next) - else go next (Option.map ((+) 1) pos) - in fun pos -> go gen pos + if predicate t then Generator.Value (t, go next) + else go next (Option.map (( + ) 1) pos) + in + fun pos -> go gen pos in - Ok (of_generator ~name:("σ_" ^ rel.Relation.name) ~schema:rel.Relation.schema - ?constraints:rel.Relation.constraints lazy_gen) + Ok + (of_generator + ~name:("σ_" ^ rel.Relation.name) + ~schema:rel.Relation.schema ?constraints:rel.Relation.constraints + lazy_gen) let project storage (attrs : string list) rel = let gen = to_generator storage rel in let project_tuple = function | Tuple.Materialized t -> - let attrs' = List.fold_left (fun acc k -> - match Tuple.AttributeMap.find_opt k t.Tuple.attributes with - | None -> acc - | Some v -> Tuple.AttributeMap.add k v acc) - Tuple.AttributeMap.empty attrs in - Tuple.Materialized { t with attributes = attrs' } + let attrs' = + List.fold_left + (fun acc k -> + match Tuple.AttributeMap.find_opt k t.Tuple.attributes with + | None -> acc + | Some v -> Tuple.AttributeMap.add k v acc) + Tuple.AttributeMap.empty attrs + in + Tuple.Materialized { t with attributes = attrs' } | other -> other in - let new_schema = List.filter (fun (n, _) -> List.mem n attrs) rel.Relation.schema in + let new_schema = + List.filter (fun (n, _) -> List.mem n attrs) rel.Relation.schema + in let lazy_gen = - let rec go g pos = match g pos with - | Generator.Done -> Generator.Done + let rec go g pos = + match g pos with + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> Generator.Value (project_tuple t, go next) - in fun pos -> go gen pos + in + fun pos -> go gen pos in let filtered_constraints = match rel.Relation.constraints with | None | Some [] -> None - | Some cs -> - let kept = - List.filter_map - (fun (name, c) -> - match Constraint.filter_by_attrs attrs c with - | Some c' -> Some (name, c') - | None -> None) - cs - in - (match kept with [] -> None | _ -> Some kept) + | Some cs -> ( + let kept = + List.filter_map + (fun (name, c) -> + match Constraint.filter_by_attrs attrs c with + | Some c' -> Some (name, c') + | None -> None) + cs + in + match kept with [] -> None | _ -> Some kept) in - Ok (of_generator ~name:("π_" ^ rel.Relation.name) ~schema:new_schema - ?constraints:filtered_constraints lazy_gen) + Ok + (of_generator + ~name:("π_" ^ rel.Relation.name) + ~schema:new_schema ?constraints:filtered_constraints lazy_gen) let rename storage (renames : (string * string) list) rel = - let rename_key k = match List.assoc_opt k renames with Some k' -> k' | None -> k in + let rename_key k = + match List.assoc_opt k renames with Some k' -> k' | None -> k + in let rename_tuple = function | Tuple.Materialized t -> - let attrs' = Tuple.AttributeMap.fold (fun k v acc -> - Tuple.AttributeMap.add (rename_key k) v acc) - t.Tuple.attributes Tuple.AttributeMap.empty in - Tuple.Materialized { t with attributes = attrs' } + let attrs' = + Tuple.AttributeMap.fold + (fun k v acc -> Tuple.AttributeMap.add (rename_key k) v acc) + t.Tuple.attributes Tuple.AttributeMap.empty + in + Tuple.Materialized { t with attributes = attrs' } | other -> other in let gen = to_generator storage rel in - let new_schema = List.map (fun (n, d) -> (rename_key n, d)) rel.Relation.schema in + let new_schema = + List.map (fun (n, d) -> (rename_key n, d)) rel.Relation.schema + in let lazy_gen = - let rec go g pos = match g pos with - | Generator.Done -> Generator.Done + let rec go g pos = + match g pos with + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> Generator.Value (rename_tuple t, go next) - in fun pos -> go gen pos + in + fun pos -> go gen pos in let renamed_constraints = match rel.Relation.constraints with | None | Some [] -> None | Some cs -> - Some - (List.map - (fun (name, c) -> (name, Constraint.rename_vars renames c)) - cs) + Some + (List.map + (fun (name, c) -> (name, Constraint.rename_vars renames c)) + cs) in - Ok (of_generator ~name:("ρ_" ^ rel.Relation.name) ~schema:new_schema - ?constraints:renamed_constraints lazy_gen) + Ok + (of_generator + ~name:("ρ_" ^ rel.Relation.name) + ~schema:new_schema ?constraints:renamed_constraints lazy_gen) let equijoin storage (attrs : string list) left right = let right_gen = to_generator storage right in match drain right_gen with | Error e -> Error e | Ok right_tuples -> - let left_gen = to_generator storage left in - let get_vals attr_list = function - | Tuple.Materialized t -> - List.map (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) attr_list - | _ -> List.map (fun _ -> None) attr_list - in - let merge lt rt = match lt, rt with - | Tuple.Materialized l, Tuple.Materialized r -> - Tuple.Materialized { l with attributes = - Tuple.AttributeMap.union (fun _ a _ -> Some a) - l.Tuple.attributes r.Tuple.attributes } - | _ -> lt - in - let merged_schema = - left.Relation.schema @ - List.filter (fun (n, _) -> - not (List.mem n attrs) && - not (List.exists (fun (m, _) -> m = n) left.Relation.schema)) - right.Relation.schema - in - let join_gen = - let rec chain_with_cont g cont pos = - match g pos with - | Generator.Done -> cont pos - | Generator.Value (t, next) -> Generator.Value (t, fun p -> chain_with_cont next cont p) - | Generator.Error e -> Generator.Error e + let left_gen = to_generator storage left in + let get_vals attr_list = function + | Tuple.Materialized t -> + List.map + (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) + attr_list + | _ -> List.map (fun _ -> None) attr_list in - let rec from_left lgen lpos = - fun pos -> - match lgen (Some lpos) with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (lt, next_left) -> - let lv = get_vals attrs lt in - let matches = List.filter_map (fun rt -> - if get_vals attrs rt = lv then Some (merge lt rt) else None) right_tuples in - (match matches with - | [] -> from_left next_left (lpos + 1) pos - | _ -> - chain_with_cont (list_generator matches) - (from_left next_left (lpos + 1)) pos) + let merge lt rt = + match (lt, rt) with + | Tuple.Materialized l, Tuple.Materialized r -> + Tuple.Materialized + { + l with + attributes = + Tuple.AttributeMap.union + (fun _ a _ -> Some a) + l.Tuple.attributes r.Tuple.attributes; + } + | _ -> lt in - from_left left_gen 0 - in - let merged_constraints = - match left.Relation.constraints, right.Relation.constraints with - | None, None -> None - | Some cs, None | None, Some cs -> Some cs - | Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2) - in - let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in - Ok (of_generator ~name ~schema:merged_schema + let merged_schema = + left.Relation.schema + @ List.filter + (fun (n, _) -> + (not (List.mem n attrs)) + && not (List.exists (fun (m, _) -> m = n) left.Relation.schema)) + right.Relation.schema + in + let join_gen = + let rec chain_with_cont g cont pos = + match g pos with + | Generator.Done -> cont pos + | Generator.Value (t, next) -> + Generator.Value (t, fun p -> chain_with_cont next cont p) + | Generator.Error e -> Generator.Error e + in + let rec from_left lgen lpos = + fun pos -> + match lgen (Some lpos) with + | Generator.Done -> Generator.Done + | Generator.Error e -> Generator.Error e + | Generator.Value (lt, next_left) -> ( + let lv = get_vals attrs lt in + let matches = + List.filter_map + (fun rt -> + if get_vals attrs rt = lv then Some (merge lt rt) + else None) + right_tuples + in + match matches with + | [] -> from_left next_left (lpos + 1) pos + | _ -> + chain_with_cont (list_generator matches) + (from_left next_left (lpos + 1)) + pos) + in + from_left left_gen 0 + in + let merged_constraints = + match (left.Relation.constraints, right.Relation.constraints) with + | None, None -> None + | Some cs, None | None, Some cs -> Some cs + | Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2) + in + let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in + Ok + (of_generator ~name ~schema:merged_schema ?constraints:merged_constraints join_gen) let union storage rel1 rel2 = @@ -208,47 +251,55 @@ module Make(Storage : Management.Physical.S) = struct let chain_gen = let rec go g1 g2 pos = match g1 pos with - | Generator.Done -> g2 pos + | Generator.Done -> g2 pos | Generator.Error _ -> g2 pos | Generator.Value (t, next) -> Generator.Value (t, fun p -> go next g2 p) - in fun pos -> go gen1 gen2 pos + in + fun pos -> go gen1 gen2 pos in let name = "∪_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in (* Conservative: drop constraints since they only hold if both inputs agree *) Ok (of_generator ~name ~schema:rel1.Relation.schema chain_gen) - let attrs_equal - (m1 : Attribute.materialized Tuple.AttributeMap.t) + let attrs_equal (m1 : Attribute.materialized Tuple.AttributeMap.t) (m2 : Attribute.materialized Tuple.AttributeMap.t) = Tuple.AttributeMap.equal - (fun a b -> Stdlib.(=) a.Attribute.value b.Attribute.value) m1 m2 + (fun a b -> Stdlib.( = ) a.Attribute.value b.Attribute.value) + m1 m2 let diff storage rel1 rel2 = let right_gen = to_generator storage rel2 in match drain right_gen with | Error e -> Error e | Ok right_tuples -> - let right_mats = List.filter_map (function - | Tuple.Materialized t -> Some t | _ -> None) right_tuples in - let left_gen = to_generator storage rel1 in - let not_in_right = function - | Tuple.Materialized t -> - not (List.exists (fun r -> - attrs_equal t.Tuple.attributes r.Tuple.attributes) right_mats) - | _ -> true - in - let lazy_gen = - let rec go g pos = - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> - if not_in_right t then Generator.Value (t, go next) - else go next (Option.map ((+) 1) pos) - in fun pos -> go left_gen pos - in - let name = "−_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in - Ok (of_generator ~name ~schema:rel1.Relation.schema + let right_mats = + List.filter_map + (function Tuple.Materialized t -> Some t | _ -> None) + right_tuples + in + let left_gen = to_generator storage rel1 in + let not_in_right = function + | Tuple.Materialized t -> + not + (List.exists + (fun r -> attrs_equal t.Tuple.attributes r.Tuple.attributes) + right_mats) + | _ -> true + in + let lazy_gen = + let rec go g pos = + match g pos with + | Generator.Done -> Generator.Done + | Generator.Error e -> Generator.Error e + | Generator.Value (t, next) -> + if not_in_right t then Generator.Value (t, go next) + else go next (Option.map (( + ) 1) pos) + in + fun pos -> go left_gen pos + in + let name = "−_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in + Ok + (of_generator ~name ~schema:rel1.Relation.schema ?constraints:rel1.Relation.constraints lazy_gen) let take storage n rel = @@ -256,22 +307,28 @@ module Make(Storage : Management.Physical.S) = struct let lazy_gen = let rec go g count pos = if count = 0 then Generator.Done - else match g pos with - | Generator.Done -> Generator.Done + else + match g pos with + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> Generator.Value (t, go next (count - 1)) - in fun pos -> go gen n pos + in + fun pos -> go gen n pos in - Ok (of_generator ~name:("τ_" ^ rel.Relation.name) ~schema:rel.Relation.schema - ?constraints:rel.Relation.constraints - ~cardinality:(Conventions.Cardinality.Finite n) lazy_gen) + Ok + (of_generator + ~name:("τ_" ^ rel.Relation.name) + ~schema:rel.Relation.schema ?constraints:rel.Relation.constraints + ~cardinality:(Conventions.Cardinality.Finite n) lazy_gen) let materialize storage rel : (Tuple.materialized list, error) Result.t = match drain (to_generator storage rel) with | Error e -> Error e | Ok tuples -> - Ok (List.filter_map (function Tuple.Materialized t -> Some t | _ -> None) tuples) - + Ok + (List.filter_map + (function Tuple.Materialized t -> Some t | _ -> None) + tuples) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/attribute.ml b/lib/attribute.ml index f3fc0b1..b828d64 100644 --- a/lib/attribute.ml +++ b/lib/attribute.ml @@ -1,15 +1,11 @@ type referenced = { value_hash : Conventions.Hash.t } [@@deriving sexp_of] +type materialized = { value : Conventions.AbstractValue.t } [@@deriving sexp_of] -type materialized = { value: Conventions.AbstractValue.t } [@@deriving sexp_of] - -type t = - | Referenced of referenced - | Materialized of materialized +type t = Referenced of referenced | Materialized of materialized [@@deriving sexp_of] let make_referenced ~value = let value_hash = Conventions.AbstractValue.hash value in Referenced { value_hash } -let make_materialized ~value = - Materialized { value }
\ No newline at end of file +let make_materialized ~value = Materialized { value } diff --git a/lib/conventions.ml b/lib/conventions.ml index 60069b0..b6f82a5 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -1,5 +1,6 @@ module Hash = struct type t = Interop.Sha256.t + let hash_text text = Interop.Sha256.compute_hash (Bytes.of_string text) let compare = String.compare let sexp_of_t = Sexplib.Std.sexp_of_string @@ -7,21 +8,25 @@ end module Name = struct type t = string + let sexp_of_t = Sexplib.Std.sexp_of_string end module Cardinality = struct type t = Finite of int | ConstrainedFinite | AlephZero | Continuum + let sexp_of_t = function - | Finite n -> Sexplib.Sexp.(List [Atom "Finite"; Atom (string_of_int n)]) + | Finite n -> Sexplib.Sexp.(List [ Atom "Finite"; Atom (string_of_int n) ]) | ConstrainedFinite -> Sexplib.Sexp.Atom "ConstrainedFinite" - | AlephZero -> Sexplib.Sexp.Atom "AlephZero" - | Continuum -> Sexplib.Sexp.Atom "Continuum" + | AlephZero -> Sexplib.Sexp.Atom "AlephZero" + | Continuum -> Sexplib.Sexp.Atom "Continuum" end module AbstractValue = struct type t = Obj.t - let hash (elem: t) = Interop.Sha256.compute_hash @@ Marshal.to_bytes elem [] + + let hash (elem : t) = Interop.Sha256.compute_hash @@ Marshal.to_bytes elem [] + let sexp_of_t (v : t) = let open Sexplib.Sexp in if Obj.is_int v then Atom (string_of_int (Obj.obj v : int)) @@ -33,4 +38,4 @@ module AbstractValue = struct if Float.is_nan f || Float.is_infinite f then Atom "nan" else Atom (string_of_float f) else Atom "<opaque>" -end
\ No newline at end of file +end diff --git a/lib/core_functions.ml b/lib/core_functions.ml index 39094cc..9cb6213 100644 --- a/lib/core_functions.ml +++ b/lib/core_functions.ml @@ -20,5 +20,4 @@ module Functions (F : Ctypes.FOREIGN) = struct let compute_hash = Foreign.foreign ~from:libmerklecpp "compute_hash" (ptr char @-> Ctypes.string @-> returning void) - end diff --git a/lib/dbms_language.ml b/lib/dbms_language.ml index 8d61aa3..47e5a99 100644 --- a/lib/dbms_language.ml +++ b/lib/dbms_language.ml @@ -1,39 +1,37 @@ (** Composable dispatch over sublanguages. - All commands must use the tagged envelope format: (tag payload) - where [tag] is the sublanguage name (drl, dml, ddl, icl, dcl, ...). - Adding a new sublanguage is just extending the list passed to [create]. *) + All commands must use the tagged envelope format: (tag payload) where [tag] + is the sublanguage name (drl, dml, ddl, icl, dcl, ...). Adding a new + sublanguage is just extending the list passed to [create]. *) module Make (Storage : Management.Physical.S with type error = string) = struct module type SubS = Sublanguage.S with type storage = Storage.t type dispatch_error = NoMatch of Sexplib.Sexp.t - type dispatch = (module SubS) list let create (langs : (module SubS) list) : dispatch = langs - let execute - (langs : dispatch) - (storage : Storage.t) - (db : Management.Database.t) - (input : string) - : (Sublanguage.result, dispatch_error) Result.t = - let no_match s = Error (NoMatch Sexplib.Sexp.(List [Atom "parse-error"; Atom s])) in + let execute (langs : dispatch) (storage : Storage.t) + (db : Management.Database.t) (input : string) : + (Sublanguage.result, dispatch_error) Result.t = + let no_match s = + Error (NoMatch Sexplib.Sexp.(List [ Atom "parse-error"; Atom s ])) + in match Envelope.parse input with | Error msg -> no_match msg - | Ok { tag; payload } -> - match List.find_opt (fun (module L : SubS) -> L.name = tag) langs with - | None -> no_match ("unknown sublanguage: " ^ tag) - | Some (module L) -> - match L.parse_sexp payload with - | Error e -> Error (NoMatch (L.sexp_of_error e)) - | Ok ast -> - match L.execute storage db ast with - | Ok result -> Ok result - | Error e -> Error (NoMatch (L.sexp_of_error e)) + | Ok { tag; payload } -> ( + match List.find_opt (fun (module L : SubS) -> L.name = tag) langs with + | None -> no_match ("unknown sublanguage: " ^ tag) + | Some (module L) -> ( + match L.parse_sexp payload with + | Error e -> Error (NoMatch (L.sexp_of_error e)) + | Ok ast -> ( + match L.execute storage db ast with + | Ok result -> Ok result + | Error e -> Error (NoMatch (L.sexp_of_error e))))) let sexp_of_dispatch_error (NoMatch sexp) = sexp end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml index e1dae13..0b6107f 100644 --- a/lib/dcl/ast.ml +++ b/lib/dcl/ast.ml @@ -4,10 +4,10 @@ type merge_strategy = PreferLeft | PreferRight | RevertToAncestor [@@deriving sexp] type statement = - | CreateBranch of { name: string; hash: string option [@sexp.option] } + | CreateBranch of { name : string; hash : string option [@sexp.option] } | Checkout of string | GetHead | GetBranchTip of string - | UpdateBranchTip of { name: string; hash: string } - | Merge of { left: string; right: string; strategy: merge_strategy } + | UpdateBranchTip of { name : string; hash : string } + | Merge of { left : string; right : string; strategy : merge_strategy } [@@deriving sexp] diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml index cf2cfed..8c2fbdc 100644 --- a/lib/dcl/executor.ml +++ b/lib/dcl/executor.ml @@ -1,94 +1,94 @@ module Make (Storage : Management.Physical.S with type error = string) = struct - module Ops = Manipulation.Make(Storage) - module Branch = Management.Branch.Make(Storage) - module MergeOps = Management.Merge.Make(Storage)(Ops) + module Ops = Manipulation.Make (Storage) + module Branch = Management.Branch.Make (Storage) + module MergeOps = Management.Merge.Make (Storage) (Ops) type error = - | ParseError of string + | ParseError of string | BranchError of string - | MergeError of string + | MergeError of string let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | BranchError s -> List [Atom "branch-error"; Atom s] - | MergeError s -> List [Atom "merge-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | BranchError s -> List [ Atom "branch-error"; Atom s ] + | MergeError s -> List [ Atom "merge-error"; Atom s ] - let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = function - | Ast.PreferLeft -> Management.Merge.PreferLeft - | Ast.PreferRight -> Management.Merge.PreferRight + let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = + function + | Ast.PreferLeft -> Management.Merge.PreferLeft + | Ast.PreferRight -> Management.Merge.PreferRight | Ast.RevertToAncestor -> Management.Merge.RevertToAncestor - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (Management.Database.t * string, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (Management.Database.t * string, error) result = match stmt with - - | Ast.CreateBranch { name; hash } -> - let tip = match hash with - | Some h -> h - | None -> db.Management.Database.hash - in - (match Branch.create storage ~name ~tip with - | Error e -> Error (BranchError e) - | Ok () -> Ok (db, "Branch " ^ name ^ " created")) - - | Ast.Checkout branch_name -> - (match Branch.get_tip storage branch_name with - | Error e -> Error (BranchError e) - | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name)) - | Ok (Some tip) -> - (match Branch.checkout storage branch_name with - | Error e -> Error (BranchError e) - | Ok () -> - (match Ops.load_database storage tip with - | Error e -> Error (BranchError (Manipulation.string_of_error e)) - | Ok None -> Error (BranchError ("No database at hash: " ^ tip)) - | Ok (Some loaded_db) -> - Ok (loaded_db, "HEAD:" ^ branch_name)))) - - | Ast.GetHead -> - (match Branch.get_head storage with - | Error e -> Error (BranchError e) - | Ok None -> Ok (db, "HEAD is unset") - | Ok (Some name) -> Ok (db, "HEAD:" ^ name)) - - | Ast.GetBranchTip name -> - (match Branch.get_tip storage name with - | Error e -> Error (BranchError e) - | Ok None -> Error (BranchError ("Branch not found: " ^ name)) - | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash)) - - | Ast.UpdateBranchTip { name; hash } -> - (match Branch.update_tip storage ~name ~tip:hash with - | Error e -> Error (BranchError e) - | Ok () -> Ok (db, "Branch " ^ name ^ " updated")) - - | Ast.Merge { left; right; strategy } -> - (match Branch.get_tip storage left, Branch.get_tip storage right with - | Error e, _ | _, Error e -> Error (BranchError e) - | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left)) - | _, Ok None -> Error (BranchError ("Branch not found: " ^ right)) - | Ok (Some left_tip), Ok (Some right_tip) -> - let strat = convert_strategy strategy in - (match MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip with - | Error e -> Error (MergeError (Manipulation.string_of_error e)) - | Ok (Management.Merge.Failed conflicts) -> - let msgs = List.map (function - | Management.Merge.TupleConflict { relation; hash } -> - "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")" - | Management.Merge.SchemaConflict r -> "schema conflict in " ^ r - | Management.Merge.ConstraintConflict r -> "constraint conflict in " ^ r - ) conflicts in - Error (MergeError ("Merge failed: " ^ String.concat "; " msgs)) - | Ok (Management.Merge.Clean merged_db) -> - let _ = Branch.update_tip storage ~name:left - ~tip:merged_db.Management.Database.hash in - Ok (merged_db, - "Merged:" ^ right ^ "→" ^ left))) + | Ast.CreateBranch { name; hash } -> ( + let tip = + match hash with Some h -> h | None -> db.Management.Database.hash + in + match Branch.create storage ~name ~tip with + | Error e -> Error (BranchError e) + | Ok () -> Ok (db, "Branch " ^ name ^ " created")) + | Ast.Checkout branch_name -> ( + match Branch.get_tip storage branch_name with + | Error e -> Error (BranchError e) + | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name)) + | Ok (Some tip) -> ( + match Branch.checkout storage branch_name with + | Error e -> Error (BranchError e) + | Ok () -> ( + match Ops.load_database storage tip with + | Error e -> + Error (BranchError (Manipulation.string_of_error e)) + | Ok None -> Error (BranchError ("No database at hash: " ^ tip)) + | Ok (Some loaded_db) -> Ok (loaded_db, "HEAD:" ^ branch_name))) + ) + | Ast.GetHead -> ( + match Branch.get_head storage with + | Error e -> Error (BranchError e) + | Ok None -> Ok (db, "HEAD is unset") + | Ok (Some name) -> Ok (db, "HEAD:" ^ name)) + | Ast.GetBranchTip name -> ( + match Branch.get_tip storage name with + | Error e -> Error (BranchError e) + | Ok None -> Error (BranchError ("Branch not found: " ^ name)) + | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash)) + | Ast.UpdateBranchTip { name; hash } -> ( + match Branch.update_tip storage ~name ~tip:hash with + | Error e -> Error (BranchError e) + | Ok () -> Ok (db, "Branch " ^ name ^ " updated")) + | Ast.Merge { left; right; strategy } -> ( + match (Branch.get_tip storage left, Branch.get_tip storage right) with + | Error e, _ | _, Error e -> Error (BranchError e) + | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left)) + | _, Ok None -> Error (BranchError ("Branch not found: " ^ right)) + | Ok (Some left_tip), Ok (Some right_tip) -> ( + let strat = convert_strategy strategy in + match + MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip + with + | Error e -> Error (MergeError (Manipulation.string_of_error e)) + | Ok (Management.Merge.Failed conflicts) -> + let msgs = + List.map + (function + | Management.Merge.TupleConflict { relation; hash } -> + "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")" + | Management.Merge.SchemaConflict r -> + "schema conflict in " ^ r + | Management.Merge.ConstraintConflict r -> + "constraint conflict in " ^ r) + conflicts + in + Error (MergeError ("Merge failed: " ^ String.concat "; " msgs)) + | Ok (Management.Merge.Clean merged_db) -> + let _ = + Branch.update_tip storage ~name:left + ~tip:merged_db.Management.Database.hash + in + Ok (merged_db, "Merged:" ^ right ^ "→" ^ left))) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml index ef64924..79d8fc7 100644 --- a/lib/dcl/parser.ml +++ b/lib/dcl/parser.ml @@ -3,16 +3,12 @@ type error = ParseError of string let of_sexp sexp = (* ppx_sexp_conv encodes no-argument variants as bare atoms, so unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *) - let sexp = match sexp with - | Sexplib.Sexp.List [atom] -> atom - | other -> other + let sexp = + match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other in match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) -let of_string s = - of_sexp (Sexplib.Sexp.of_string s) - -let to_string stmt = - Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum +let of_string s = of_sexp (Sexplib.Sexp.of_string s) +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml index 112b6ed..c36e2a4 100644 --- a/lib/dcl/sublanguage.ml +++ b/lib/dcl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S with type error = string) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "dcl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S with type error = string) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/ddl/ast.ml b/lib/ddl/ast.ml index 7faee40..ee39edb 100644 --- a/lib/ddl/ast.ml +++ b/lib/ddl/ast.ml @@ -9,8 +9,8 @@ type cardinality_spec = type statement = | CreateDatabase of string - | CreateRelation of { name: string; schema: (string * string) list } + | CreateRelation of { name : string; schema : (string * string) list } | RetractRelation of string | ClearRelation of string - | RegisterDomain of { name: string; cardinality: cardinality_spec } + | RegisterDomain of { name : string; cardinality : cardinality_spec } [@@deriving sexp] diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml index fbb2f62..d374ffe 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -1,68 +1,64 @@ module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) + module Ops = Manipulation.Make (Storage) type error = - | ParseError of string + | ParseError of string | ManipulationError of Manipulation.error - | RelationNotFound of string + | RelationNotFound of string let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] | ManipulationError e -> Manipulation.sexp_of_error e - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] + | 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) + 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 + 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 = + 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) - + 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) - + 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) - + 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) - + 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) + 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) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml index 28f8b6c..5678b47 100644 --- a/lib/ddl/parser.ml +++ b/lib/ddl/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | 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 + | 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 +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 index 26a012f..bf40a05 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "ddl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dml/ast.ml b/lib/dml/ast.ml index 479437a..d8defe6 100644 --- a/lib/dml/ast.ml +++ b/lib/dml/ast.ml @@ -1,13 +1,12 @@ open Sexplib.Std -type attr_value = string * Drl.Ast.value -[@@deriving sexp] +type attr_value = string * Drl.Ast.value [@@deriving sexp] type statement = - | InsertTuple of { relation: string; attributes: attr_value list } - | InsertTuples of { relation: string; tuples: attr_value list list } - | DeleteTuple of { relation: string; attributes: attr_value list } - | Assign of { target: string; body: Drl.Ast.query } - | InsertFrom of { target: string; source: Drl.Ast.query } - | DeleteWhere of { target: string; predicate: Drl.Ast.query } + | InsertTuple of { relation : string; attributes : attr_value list } + | InsertTuples of { relation : string; tuples : attr_value list list } + | DeleteTuple of { relation : string; attributes : attr_value list } + | Assign of { target : string; body : Drl.Ast.query } + | InsertFrom of { target : string; source : Drl.Ast.query } + | DeleteWhere of { target : string; predicate : Drl.Ast.query } [@@deriving sexp] diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml index 7c08a24..08f1a26 100644 --- a/lib/dml/executor.ml +++ b/lib/dml/executor.ml @@ -1,117 +1,131 @@ module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) - module Alg = Algebra.Make(Storage) - module DrlExec = Drl.Executor.Make(Storage) + module Ops = Manipulation.Make (Storage) + module Alg = Algebra.Make (Storage) + module DrlExec = Drl.Executor.Make (Storage) type error = - | ParseError of string + | ParseError of string | ManipulationError of Manipulation.error - | RelationNotFound of string - | AlgebraError of Algebra.error + | RelationNotFound of string + | AlgebraError of Algebra.error 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] - | AlgebraError (Algebra.StorageError s) -> List [Atom "storage-error"; Atom s] - | AlgebraError (Algebra.GeneratorError s) -> List [Atom "generator-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | ManipulationError e -> Manipulation.sexp_of_error e + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + | AlgebraError (Algebra.StorageError s) -> + List [ Atom "storage-error"; Atom s ] + | AlgebraError (Algebra.GeneratorError s) -> + List [ Atom "generator-error"; Atom s ] let ( let* ) = Result.bind - let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r - let wrap_alg e = AlgebraError e let get_rel db name = match Ops.get_relation db ~name with | Some r -> Ok r - | None -> Error (RelationNotFound name) + | None -> Error (RelationNotFound name) - let retarget target (t : Tuple.materialized) = { t with Tuple.relation = target } + let retarget target (t : Tuple.materialized) = + { t with Tuple.relation = target } (** Build a materialized tuple from a list of (attr_name, ast_value) pairs *) - let build_tuple ~relation (attributes : Ast.attr_value list) : Tuple.materialized = + let build_tuple ~relation (attributes : Ast.attr_value list) : + Tuple.materialized = let attr_map = List.fold_left (fun acc (name, value) -> Tuple.AttributeMap.add name { Attribute.value = Drl.Ast.value_to_abstract value } acc) - Tuple.AttributeMap.empty - attributes + Tuple.AttributeMap.empty attributes in { Tuple.relation; attributes = attr_map } let eval_query storage db query = match DrlExec.execute storage db query with | Ok rel -> Ok rel - | Error (DrlExec.ParseError s) -> Error (ParseError s) + | Error (DrlExec.ParseError s) -> Error (ParseError s) | Error (DrlExec.RelationNotFound s) -> Error (RelationNotFound s) - | Error (DrlExec.AlgebraError e) -> Error (AlgebraError e) + | Error (DrlExec.AlgebraError e) -> Error (AlgebraError e) let materialize_tuples storage rel = Result.map_error wrap_alg (Alg.materialize storage rel) - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (Management.Database.t, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (Management.Database.t, error) result = match stmt with | Ast.InsertTuple { relation; attributes } -> - let* rel = get_rel db relation in - let tuple = build_tuple ~relation attributes in - let* (db, _, _) = Ops.create_tuple storage db rel tuple |> wrap_manip in - Ok db - + let* rel = get_rel db relation in + let tuple = build_tuple ~relation attributes in + let* db, _, _ = Ops.create_tuple storage db rel tuple |> wrap_manip in + Ok db | Ast.InsertTuples { relation; tuples } -> - let* rel = get_rel db relation in - let tuple_list = List.map (build_tuple ~relation) tuples in - let* (db, _, _) = Ops.create_tuples storage db rel tuple_list |> wrap_manip in - Ok db - + let* rel = get_rel db relation in + let tuple_list = List.map (build_tuple ~relation) tuples in + let* db, _, _ = + Ops.create_tuples storage db rel tuple_list |> wrap_manip + in + Ok db | Ast.DeleteTuple { relation; attributes } -> - let* rel = get_rel db relation in - let tuple = build_tuple ~relation attributes in - let tuple_hash = Hashing.hash_tuple tuple in - let* (db, _) = Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip in - Ok db - + let* rel = get_rel db relation in + let tuple = build_tuple ~relation attributes in + let tuple_hash = Hashing.hash_tuple tuple in + let* db, _ = + Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip + in + Ok db | Ast.Assign { target; body } -> - let* rel = get_rel db target in - let* result_rel = eval_query storage db body in - let* tuples = materialize_tuples storage result_rel in - let* (db, rel) = Ops.clear_relation storage db rel |> wrap_manip in - let* (db, _, _) = Ops.create_tuples storage db rel (List.map (retarget target) tuples) |> wrap_manip in - Ok db - + let* rel = get_rel db target in + let* result_rel = eval_query storage db body in + let* tuples = materialize_tuples storage result_rel in + let* db, rel = Ops.clear_relation storage db rel |> wrap_manip in + let* db, _, _ = + Ops.create_tuples storage db rel (List.map (retarget target) tuples) + |> wrap_manip + in + Ok db | Ast.InsertFrom { target; source } -> - let* rel = get_rel db target in - let* result_rel = eval_query storage db source in - let* tuples = materialize_tuples storage result_rel in - let* (db, _, _) = Ops.create_tuples storage db rel (List.map (retarget target) tuples) |> wrap_manip in - Ok db - + let* rel = get_rel db target in + let* result_rel = eval_query storage db source in + let* tuples = materialize_tuples storage result_rel in + let* db, _, _ = + Ops.create_tuples storage db rel (List.map (retarget target) tuples) + |> wrap_manip + in + Ok db | Ast.DeleteWhere { target; predicate } -> - let* rel = get_rel db target in - let* pred_rel = eval_query storage db predicate in - let common = List.filter_map - (fun (n, _) -> if List.exists (fun (m, _) -> m = n) pred_rel.Relation.schema - then Some n else None) - rel.Relation.schema in - let* joined = Alg.equijoin storage common rel pred_rel |> Result.map_error wrap_alg in - let* to_delete = Alg.project storage (List.map fst rel.Relation.schema) joined - |> Result.map_error wrap_alg in - let* tuples = materialize_tuples storage to_delete in - List.fold_left (fun acc t -> - let* db = acc in let* rel = get_rel db target in - let tuple_hash = Hashing.hash_tuple (retarget target t) in - let* (db, _) = Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip in - Ok db) - (Ok db) tuples + let* pred_rel = eval_query storage db predicate in + let common = + List.filter_map + (fun (n, _) -> + if List.exists (fun (m, _) -> m = n) pred_rel.Relation.schema then + Some n + else None) + rel.Relation.schema + in + let* joined = + Alg.equijoin storage common rel pred_rel |> Result.map_error wrap_alg + in + let* to_delete = + Alg.project storage (List.map fst rel.Relation.schema) joined + |> Result.map_error wrap_alg + in + let* tuples = materialize_tuples storage to_delete in + List.fold_left + (fun acc t -> + let* db = acc in + let* rel = get_rel db target in + let tuple_hash = Hashing.hash_tuple (retarget target t) in + let* db, _ = + Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip + in + Ok db) + (Ok db) tuples end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dml/parser.ml b/lib/dml/parser.ml index 28f8b6c..5678b47 100644 --- a/lib/dml/parser.ml +++ b/lib/dml/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | 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 + | 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 +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index 29f951e..29b1b77 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "dml" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl/ast.ml b/lib/drl/ast.ml index 2beb010..6b191bb 100644 --- a/lib/drl/ast.ml +++ b/lib/drl/ast.ml @@ -1,32 +1,28 @@ open Sexplib.Std (** Literal values for Const nodes *) -type value = - | Int of int - | Float of float - | Str of string - | Bool of bool +type value = Int of int | Float of float | Str of string | Bool of bool [@@deriving sexp] (** Convert an AST value to an AbstractValue.t (Obj.t) via Obj.repr *) let value_to_abstract : value -> Conventions.AbstractValue.t = function - | Int n -> Obj.repr n + | Int n -> Obj.repr n | Float f -> Obj.repr f - | Str s -> Obj.repr s - | Bool b -> Obj.repr b + | Str s -> Obj.repr s + | Bool b -> Obj.repr b -type direction = Asc | Desc -[@@deriving sexp] +type direction = Asc | Desc [@@deriving sexp] type query = - | Base of string (** base relation by name *) - | Const of (string * value) list (** constant single-tuple relation *) - | Select of query * query (** σ semijoin: (filter, source) *) - | Join of string list * query * query (** ⋈ natural equijoin on named attrs *) - | Cartesian of query * query (** × Cartesian product *) - | Project of string list * query (** π restrict columns *) - | Rename of (string * string) list * query (** ρ rename (old,new) pairs *) - | Union of query * query (** ∪ — compatible schemas assumed *) - | Diff of query * query (** − *) - | Take of int * query (** τ *) + | Base of string (** base relation by name *) + | Const of (string * value) list (** constant single-tuple relation *) + | Select of query * query (** σ semijoin: (filter, source) *) + | Join of string list * query * query + (** ⋈ natural equijoin on named attrs *) + | Cartesian of query * query (** × Cartesian product *) + | Project of string list * query (** π restrict columns *) + | Rename of (string * string) list * query (** ρ rename (old,new) pairs *) + | Union of query * query (** ∪ — compatible schemas assumed *) + | Diff of query * query (** − *) + | Take of int * query (** τ *) [@@deriving sexp] diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index 322fada..f1732eb 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -1,74 +1,74 @@ -module Make(Storage : Management.Physical.S) = struct - module Alg = Algebra.Make(Storage) - module Ops = Manipulation.Make(Storage) +module Make (Storage : Management.Physical.S) = struct + module Alg = Algebra.Make (Storage) + module Ops = Manipulation.Make (Storage) type error = - | ParseError of string + | ParseError of string | RelationNotFound of string - | AlgebraError of Algebra.error + | AlgebraError of Algebra.error let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] - | AlgebraError (Algebra.StorageError s) -> List [Atom "storage-error"; Atom s] - | AlgebraError (Algebra.GeneratorError s) -> List [Atom "generator-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + | AlgebraError (Algebra.StorageError s) -> + List [ Atom "storage-error"; Atom s ] + | AlgebraError (Algebra.GeneratorError s) -> + List [ Atom "generator-error"; Atom s ] let wrap = Result.map_error (fun e -> AlgebraError e) - let ast_value_to_abstract = Ast.value_to_abstract - let rec execute - (storage : Storage.t) - (db : Management.Database.t) - (q : Ast.query) - : (Relation.t, error) Result.t = + let rec execute (storage : Storage.t) (db : Management.Database.t) + (q : Ast.query) : (Relation.t, error) Result.t = let ( >>= ) = Result.bind in match q with - | Ast.Base name -> - (match Ops.get_relation db ~name with - | None -> Error (RelationNotFound name) - | Some rel -> Ok rel) + | Ast.Base name -> ( + match Ops.get_relation db ~name with + | None -> Error (RelationNotFound name) + | Some rel -> Ok rel) | Ast.Const pairs -> - Ok (Alg.const_relation - (List.map (fun (k, v) -> (k, ast_value_to_abstract v)) pairs)) + Ok + (Alg.const_relation + (List.map (fun (k, v) -> (k, ast_value_to_abstract v)) pairs)) | Ast.Select (filter_q, source_q) -> - execute storage db filter_q >>= fun filter -> - execute storage db source_q >>= fun source -> - (* semijoin = project(source attrs, equijoin on common attrs) *) - let common = List.filter_map (fun (n, _) -> - if List.exists (fun (m, _) -> m = n) filter.Relation.schema - then Some n else None) source.Relation.schema in - let source_attrs = List.map fst source.Relation.schema in - wrap (Alg.equijoin storage common source filter) >>= fun joined -> - wrap (Alg.project storage source_attrs joined) + execute storage db filter_q >>= fun filter -> + execute storage db source_q >>= fun source -> + (* semijoin = project(source attrs, equijoin on common attrs) *) + let common = + List.filter_map + (fun (n, _) -> + if List.exists (fun (m, _) -> m = n) filter.Relation.schema then + Some n + else None) + source.Relation.schema + in + let source_attrs = List.map fst source.Relation.schema in + wrap (Alg.equijoin storage common source filter) >>= fun joined -> + wrap (Alg.project storage source_attrs joined) | Ast.Join (attrs, q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.equijoin storage attrs r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> + wrap (Alg.equijoin storage attrs r1 r2) | Ast.Project (attrs, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.project storage attrs rel) + execute storage db q >>= fun rel -> wrap (Alg.project storage attrs rel) | Ast.Rename (renames, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.rename storage renames rel) + execute storage db q >>= fun rel -> + wrap (Alg.rename storage renames rel) | Ast.Cartesian (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - (* Cartesian product = join on no attrs *) - wrap (Alg.equijoin storage [] r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> + (* Cartesian product = join on no attrs *) + wrap (Alg.equijoin storage [] r1 r2) | Ast.Union (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.union storage r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> wrap (Alg.union storage r1 r2) | Ast.Diff (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.diff storage r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> wrap (Alg.diff storage r1 r2) | Ast.Take (n, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.take storage n rel) + execute storage db q >>= fun rel -> wrap (Alg.take storage n rel) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl/gate.ml b/lib/drl/gate.ml index 222e935..a314bce 100644 --- a/lib/drl/gate.ml +++ b/lib/drl/gate.ml @@ -1,8 +1,8 @@ (** Finiteness gate for DRL queries. - Converts Sakura types to Coq-extracted types and calls the - verified [predicted_finite] function. Rejects queries whose - result cannot be statically proven finite. *) + Converts Sakura types to Coq-extracted types and calls the verified + [predicted_finite] function. Rejects queries whose result cannot be + statically proven finite. *) (* -- string -> char list impedance --------------------------------- *) @@ -12,71 +12,68 @@ let string_to_chars (s : string) : char list = (* -- Sakura AST -> extracted AST ----------------------------------- *) let rec query_of_ast : Ast.query -> Drl_verified.query = function - | Ast.Base name -> - Drl_verified.Base (string_to_chars name) + | Ast.Base name -> Drl_verified.Base (string_to_chars name) | Ast.Const pairs -> - Drl_verified.Const - (List.map - (fun (k, v) -> - (string_to_chars k, value_of_ast_value v)) - pairs) + Drl_verified.Const + (List.map + (fun (k, v) -> (string_to_chars k, value_of_ast_value v)) + pairs) | Ast.Select (filter, source) -> - Drl_verified.Select (query_of_ast filter, query_of_ast source) + Drl_verified.Select (query_of_ast filter, query_of_ast source) | Ast.Join (attrs, q1, q2) -> - Drl_verified.Join - (List.map string_to_chars attrs, query_of_ast q1, query_of_ast q2) + Drl_verified.Join + (List.map string_to_chars attrs, query_of_ast q1, query_of_ast q2) | Ast.Cartesian (q1, q2) -> - Drl_verified.Cartesian (query_of_ast q1, query_of_ast q2) + Drl_verified.Cartesian (query_of_ast q1, query_of_ast q2) | Ast.Project (attrs, q) -> - Drl_verified.Project (List.map string_to_chars attrs, query_of_ast q) + Drl_verified.Project (List.map string_to_chars attrs, query_of_ast q) | Ast.Rename (renames, q) -> - Drl_verified.Rename - (List.map - (fun (o, n) -> (string_to_chars o, string_to_chars n)) - renames, - query_of_ast q) - | Ast.Union (q1, q2) -> - Drl_verified.Union (query_of_ast q1, query_of_ast q2) - | Ast.Diff (q1, q2) -> - Drl_verified.Diff (query_of_ast q1, query_of_ast q2) - | Ast.Take (n, q) -> - Drl_verified.Take (n, query_of_ast q) + Drl_verified.Rename + ( List.map (fun (o, n) -> (string_to_chars o, string_to_chars n)) renames, + query_of_ast q ) + | Ast.Union (q1, q2) -> Drl_verified.Union (query_of_ast q1, query_of_ast q2) + | Ast.Diff (q1, q2) -> Drl_verified.Diff (query_of_ast q1, query_of_ast q2) + | Ast.Take (n, q) -> Drl_verified.Take (n, query_of_ast q) and value_of_ast_value : Ast.value -> Drl_verified.literal = function - | Ast.Int n -> Drl_verified.LitInt n + | Ast.Int n -> Drl_verified.LitInt n (* The Coq model has no float literal. This truncation is harmless: the finiteness gate inspects only relation names and query structure, never literal values. *) | Ast.Float f -> Drl_verified.LitInt (int_of_float f) - | Ast.Str s -> Drl_verified.LitStr (string_to_chars s) - | Ast.Bool b -> Drl_verified.LitBool b + | Ast.Str s -> Drl_verified.LitStr (string_to_chars s) + | Ast.Bool b -> Drl_verified.LitBool b (* -- database snapshot --------------------------------------------- *) let is_finite (c : Conventions.Cardinality.t) : bool = match c with - | Conventions.Cardinality.Finite _ | Conventions.Cardinality.ConstrainedFinite -> true - | Conventions.Cardinality.AlephZero | Conventions.Cardinality.Continuum -> false + | Conventions.Cardinality.Finite _ | Conventions.Cardinality.ConstrainedFinite + -> + true + | Conventions.Cardinality.AlephZero | Conventions.Cardinality.Continuum -> + false let database_snapshot (db : Management.Database.t) : Drl_verified.database = Management.Database.RelationMap.fold (fun name (rel : Relation.t) acc -> - let entry : Drl_verified.relation = - { rel_name = string_to_chars name; - rel_finite = is_finite rel.cardinality } - in - (string_to_chars name, entry) :: acc) - db.relations - [] + let entry : Drl_verified.relation = + { + rel_name = string_to_chars name; + rel_finite = is_finite rel.cardinality; + } + in + (string_to_chars name, entry) :: acc) + db.relations [] (* -- public interface ---------------------------------------------- *) -let admit (db : Management.Database.t) (ast : Ast.query) : (unit, string) result = +let admit (db : Management.Database.t) (ast : Ast.query) : (unit, string) result + = let vdb = database_snapshot db in let vq = query_of_ast ast in match Drl_verified.predicted_finite vdb vq with | Some true -> Ok () | Some false -> - Error "query produces potentially infinite result; use Take to bound it" - | None -> - Error "referenced relation not found in finiteness check" + Error "query produces potentially infinite result; use Take to bound it" + | None -> Error "referenced relation not found in finiteness check" diff --git a/lib/drl/parser.ml b/lib/drl/parser.ml index 36ce15a..76d4b4e 100644 --- a/lib/drl/parser.ml +++ b/lib/drl/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.query_of_sexp sexp with - | q -> Ok q + | q -> Ok q | exception exn -> Error (ParseError (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.query_of_sexp with - | q -> Ok q + | q -> Ok q | exception exn -> Error (ParseError (Printexc.to_string exn)) -let to_string q = - Ast.sexp_of_query q |> Sexplib.Sexp.to_string_hum +let to_string q = Ast.sexp_of_query q |> Sexplib.Sexp.to_string_hum diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml index f57af95..ce69b56 100644 --- a/lib/drl/sublanguage.ml +++ b/lib/drl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.query - type error = Exec.error + type ast = Ast.query + type error = Exec.error let name = "drl" @@ -15,12 +15,12 @@ module Make (Storage : Management.Physical.S) = struct let execute storage db ast = match Gate.admit db ast with | Error msg -> Error (Exec.ParseError msg) - | Ok () -> - match Exec.execute storage db ast with - | Ok rel -> Ok (Sublanguage.Query rel) - | Error e -> Error e + | Ok () -> ( + match Exec.execute storage db ast with + | Ok rel -> Ok (Sublanguage.Query rel) + | Error e -> Error e) let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl_verified/drl_verified.ml b/lib/drl_verified/drl_verified.ml index b5aeaa7..868af2a 100644 --- a/lib/drl_verified/drl_verified.ml +++ b/lib/drl_verified/drl_verified.ml @@ -1,76 +1,67 @@ - (** val eqb : char list -> char list -> bool **) let rec eqb s1 s2 = match s1 with - | [] -> (match s2 with - | [] -> true - | _::_ -> false) - | c1::s1' -> - (match s2 with - | [] -> false - | c2::s2' -> if (=) c1 c2 then eqb s1' s2' else false) + | [] -> ( match s2 with [] -> true | _ :: _ -> false) + | c1 :: s1' -> ( + match s2 with + | [] -> false + | c2 :: s2' -> if c1 = c2 then eqb s1' s2' else false) type attr_name = char list - type relation = { rel_name : char list; rel_finite : bool } - type database = (char list * relation) list (** val db_lookup : char list -> database -> relation option **) let rec db_lookup name = function -| [] -> None -| p :: rest -> - let (n, r) = p in if eqb name n then Some r else db_lookup name rest + | [] -> None + | p :: rest -> + let n, r = p in + if eqb name n then Some r else db_lookup name rest -type literal = -| LitInt of int -| LitStr of char list -| LitBool of bool +type literal = LitInt of int | LitStr of char list | LitBool of bool type query = -| Base of char list -| Const of (attr_name * literal) list -| Select of query * query -| Join of attr_name list * query * query -| Cartesian of query * query -| Project of attr_name list * query -| Rename of (attr_name * attr_name) list * query -| Union of query * query -| Diff of query * query -| Take of int * query + | Base of char list + | Const of (attr_name * literal) list + | Select of query * query + | Join of attr_name list * query * query + | Cartesian of query * query + | Project of attr_name list * query + | Rename of (attr_name * attr_name) list * query + | Union of query * query + | Diff of query * query + | Take of int * query (** val predicted_finite : database -> query -> bool option **) let rec predicted_finite db = function -| Base name -> - (match db_lookup name db with - | Some r -> Some r.rel_finite - | None -> None) -| Select (_, source) -> predicted_finite db source -| Join (_, q1, q2) -> - (match predicted_finite db q1 with - | Some f1 -> - (match predicted_finite db q2 with - | Some f2 -> Some ((&&) f1 f2) + | Base name -> ( + match db_lookup name db with Some r -> Some r.rel_finite | None -> None) + | Select (_, source) -> predicted_finite db source + | Join (_, q1, q2) -> ( + match predicted_finite db q1 with + | Some f1 -> ( + match predicted_finite db q2 with + | Some f2 -> Some (f1 && f2) + | None -> None) | None -> None) - | None -> None) -| Cartesian (q1, q2) -> - (match predicted_finite db q1 with - | Some f1 -> - (match predicted_finite db q2 with - | Some f2 -> Some ((&&) f1 f2) + | Cartesian (q1, q2) -> ( + match predicted_finite db q1 with + | Some f1 -> ( + match predicted_finite db q2 with + | Some f2 -> Some (f1 && f2) + | None -> None) | None -> None) - | None -> None) -| Project (_, q0) -> predicted_finite db q0 -| Rename (_, q0) -> predicted_finite db q0 -| Union (q1, q2) -> - (match predicted_finite db q1 with - | Some f1 -> - (match predicted_finite db q2 with - | Some f2 -> Some ((&&) f1 f2) + | Project (_, q0) -> predicted_finite db q0 + | Rename (_, q0) -> predicted_finite db q0 + | Union (q1, q2) -> ( + match predicted_finite db q1 with + | Some f1 -> ( + match predicted_finite db q2 with + | Some f2 -> Some (f1 && f2) + | None -> None) | None -> None) - | None -> None) -| Diff (q1, _) -> predicted_finite db q1 -| _ -> Some true + | Diff (q1, _) -> predicted_finite db q1 + | _ -> Some true diff --git a/lib/drl_verified/drl_verified.mli b/lib/drl_verified/drl_verified.mli index 31acc7a..dac930e 100644 --- a/lib/drl_verified/drl_verified.mli +++ b/lib/drl_verified/drl_verified.mli @@ -1,29 +1,23 @@ - val eqb : char list -> char list -> bool type attr_name = char list - type relation = { rel_name : char list; rel_finite : bool } - type database = (char list * relation) list val db_lookup : char list -> database -> relation option -type literal = -| LitInt of int -| LitStr of char list -| LitBool of bool +type literal = LitInt of int | LitStr of char list | LitBool of bool type query = -| Base of char list -| Const of (attr_name * literal) list -| Select of query * query -| Join of attr_name list * query * query -| Cartesian of query * query -| Project of attr_name list * query -| Rename of (attr_name * attr_name) list * query -| Union of query * query -| Diff of query * query -| Take of int * query + | Base of char list + | Const of (attr_name * literal) list + | Select of query * query + | Join of attr_name list * query * query + | Cartesian of query * query + | Project of attr_name list * query + | Rename of (attr_name * attr_name) list * query + | Union of query * query + | Diff of query * query + | Take of int * query val predicted_finite : database -> query -> bool option @@ -1,4 +1,5 @@ (include_subdirs qualified) + (library (name relational_engine) (libraries diff --git a/lib/envelope.ml b/lib/envelope.ml index d8404d9..bed8bc0 100644 --- a/lib/envelope.ml +++ b/lib/envelope.ml @@ -1,18 +1,17 @@ (** Envelope parser for tagged S-expressions. - Parses commands of the form (tag payload...) where the tag selects - which sublanguage handles the payload. The tag set is open — future - sublanguages (tcl, ppl, acl) just add new tags. *) + Parses commands of the form (tag payload...) where the tag selects which + sublanguage handles the payload. The tag set is open — future sublanguages + (tcl, ppl, acl) just add new tags. *) type tagged = { tag : string; payload : Sexplib.Sexp.t } let parse (input : string) : (tagged, string) Result.t = match Sexplib.Sexp.of_string input with | Sexplib.Sexp.List (Sexplib.Sexp.Atom tag :: rest) -> - let payload = match rest with - | [single] -> single - | many -> Sexplib.Sexp.List many - in - Ok { tag; payload } + let payload = + match rest with [ single ] -> single | many -> Sexplib.Sexp.List many + in + Ok { tag; payload } | _ -> Error "expected (tag payload...)" | exception exn -> Error (Printexc.to_string exn) diff --git a/lib/generator.ml b/lib/generator.ml index 44f1579..5939ec9 100644 --- a/lib/generator.ml +++ b/lib/generator.ml @@ -2,5 +2,5 @@ type result = | Done | Value of Tuple.t * (int option -> result) | Error of string - - and t = int option -> result
\ No newline at end of file + +and t = int option -> result diff --git a/lib/hashing.ml b/lib/hashing.ml index 4709ded..9475e46 100644 --- a/lib/hashing.ml +++ b/lib/hashing.ml @@ -1,8 +1,8 @@ (** Hash computation for tuples and relations. This module provides content-addressable hashing for the relational engine. - All hashes are deterministic - the same content always produces the same hash. - This enables: + All hashes are deterministic - the same content always produces the same + hash. This enables: - Deduplication of tuples - Merkle tree construction for relations and databases - Time-travel queries (load any historical state by hash) *) @@ -16,38 +16,41 @@ let bytes_to_hex bytes = let hi = c lsr 4 in let lo = c land 0xf in Bytes.set hex (i * 2) (Char.chr (if hi < 10 then hi + 48 else hi + 87)); - Bytes.set hex (i * 2 + 1) (Char.chr (if lo < 10 then lo + 48 else lo + 87)); + Bytes.set hex + ((i * 2) + 1) + (Char.chr (if lo < 10 then lo + 48 else lo + 87)) done; Bytes.to_string hex -(** Compute hash for a tuple. - The hash is computed from: +(** Compute hash for a tuple. The hash is computed from: - The relation name - - All attribute names and their marshalled values (sorted by name for determinism) *) + - All attribute names and their marshalled values (sorted by name for + determinism) *) let hash_tuple (tuple : Tuple.materialized) : Conventions.Hash.t = let sorted_attrs = Tuple.AttributeMap.bindings tuple.attributes |> List.sort (fun (a, _) (b, _) -> String.compare a b) in let content = - List.fold_left (fun acc (name, attr) -> - (* Marshal the value and hex-encode to avoid null bytes *) - let value_bytes = Marshal.to_bytes attr.Attribute.value [Marshal.Closures] in - let value_hex = bytes_to_hex value_bytes in - acc ^ name ^ ":" ^ value_hex ^ ";" - ) (tuple.relation ^ "|") sorted_attrs + List.fold_left + (fun acc (name, attr) -> + (* Marshal the value and hex-encode to avoid null bytes *) + let value_bytes = + Marshal.to_bytes attr.Attribute.value [ Marshal.Closures ] + in + let value_hex = bytes_to_hex value_bytes in + acc ^ name ^ ":" ^ value_hex ^ ";") + (tuple.relation ^ "|") sorted_attrs in Conventions.Hash.hash_text content -(** Compute hash for a relation. - The hash is computed from: +(** Compute hash for a relation. The hash is computed from: - The relation name - The schema (attribute names and types) - The merkle tree root hash (representing all tuples) *) let hash_relation ~name ~(schema : Schema.t) ~tree : Conventions.Hash.t = let schema_str = Schema.to_string schema in - let tree_hash = match Merkle.root_hash tree with - | Some h -> h - | None -> "empty" + let tree_hash = + match Merkle.root_hash tree with Some h -> h | None -> "empty" in Conventions.Hash.hash_text (name ^ "|" ^ schema_str ^ "|" ^ tree_hash) diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml index 95e0271..30b0fa7 100644 --- a/lib/icl/ast.ml +++ b/lib/icl/ast.ml @@ -6,18 +6,18 @@ type binding_expr = [@@deriving sexp] type constraint_body = - | MemberOf of { target: string; binding: (string * binding_expr) list } - | Not of { body: constraint_body; universe: string } + | MemberOf of { target : string; binding : (string * binding_expr) list } + | Not of { body : constraint_body; universe : string } | And of constraint_body list | Or of constraint_body list - | Exists of { variable: string; quantifier: string; body: constraint_body } - | Forall of { variable: string; quantifier: string; body: constraint_body } + | Exists of { variable : string; quantifier : string; body : constraint_body } + | Forall of { variable : string; quantifier : string; body : constraint_body } [@@deriving sexp] type statement = | RegisterConstraint of { - constraint_name: string; - relation_name: string; - body: constraint_body; + constraint_name : string; + relation_name : string; + body : constraint_body; } [@@deriving sexp] diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml index 28f8b6c..5678b47 100644 --- a/lib/icl/parser.ml +++ b/lib/icl/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | 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 + | 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 +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index 4e74082..56f3e4b 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "icl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/interop.ml b/lib/interop.ml index ea25e0c..8cbc05c 100644 --- a/lib/interop.ml +++ b/lib/interop.ml @@ -2,7 +2,8 @@ open Ctypes module Sha256 = struct type t = string - let compute_hash content: t = + + let compute_hash content : t = let size_with_null_terminator = C.Types.hash_size + 1 in let buf = Ctypes.allocate_n char ~count:size_with_null_terminator in let () = C.Functions.compute_hash buf (Bytes.to_string content) in diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 70dfd85..ea15311 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -4,13 +4,8 @@ - "branch_names" → serialized string list (index for enumeration) - "head" → branch name as raw bytes *) -type t = { - name : string; - tip : Conventions.Hash.t; -} - +type t = { name : string; tip : Conventions.Hash.t } type head = string - type error = string let branch_key name = "branch:" ^ name @@ -18,7 +13,6 @@ let head_key = "head" let names_key = "branch_names" module Make (Storage : Physical.S with type error = string) = struct - let load_names storage = match Storage.load_raw storage names_key with | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list) @@ -31,13 +25,12 @@ module Make (Storage : Physical.S with type error = string) = struct let create storage ~name ~tip = let record = { name; tip } in let bytes = Marshal.to_bytes record [] in - (match Storage.store_raw storage (branch_key name) bytes with - | Error e -> Error e - | Ok () -> - let names = load_names storage in - if not (List.mem name names) then - store_names storage (name :: names); - Ok ()) + match Storage.store_raw storage (branch_key name) bytes with + | Error e -> Error e + | Ok () -> + let names = load_names storage in + if not (List.mem name names) then store_names storage (name :: names); + Ok () let checkout storage branch_name = let bytes = Bytes.of_string branch_name in @@ -52,27 +45,30 @@ module Make (Storage : Physical.S with type error = string) = struct let get_tip storage name = match Storage.load_raw storage (branch_key name) with | Ok (Some bytes) -> - let record : t = Marshal.from_bytes bytes 0 in - Ok (Some record.tip) + let record : t = Marshal.from_bytes bytes 0 in + Ok (Some record.tip) | Ok None -> Ok None | Error e -> Error e let update_tip storage ~name ~tip = match Storage.load_raw storage (branch_key name) with | Ok (Some _) -> - let record = { name; tip } in - let bytes = Marshal.to_bytes record [] in - Storage.store_raw storage (branch_key name) bytes + let record = { name; tip } in + let bytes = Marshal.to_bytes record [] in + Storage.store_raw storage (branch_key name) bytes | Ok None -> Error ("Branch not found: " ^ name) | Error e -> Error e let list storage = let names = load_names storage in - let branches = List.filter_map (fun name -> - match get_tip storage name with - | Ok (Some tip) -> Some (name, tip) - | _ -> None - ) names in + let branches = + List.filter_map + (fun name -> + match get_tip storage name with + | Ok (Some tip) -> Some (name, tip) + | _ -> None) + names + in Ok branches let branch_relation storage : Relation.t = @@ -83,23 +79,22 @@ module Make (Storage : Physical.S with type error = string) = struct let rec generator position = match position with | None -> Generator.Error "random access not supported for sakura:branch" - | Some pos -> - (match list storage with - | Error _ -> Generator.Done - | Ok branches -> - if pos >= List.length branches then Generator.Done - else - let (name, tip) = List.nth branches pos in - let short = String.sub tip 0 (min 8 (String.length tip)) in - let attributes = - Tuple.AttributeMap.of_list - [ ("name", mk name) - ; ("hash", mk short) - ] - in - Generator.Value - ( Tuple.make_materialized ~relation:Prelude.Catalog.branch_rel_name ~attributes - , generator )) + | Some pos -> ( + match list storage with + | Error _ -> Generator.Done + | Ok branches -> + if pos >= List.length branches then Generator.Done + else + let name, tip = List.nth branches pos in + let short = String.sub tip 0 (min 8 (String.length tip)) in + let attributes = + Tuple.AttributeMap.of_list + [ ("name", mk name); ("hash", mk short) ] + in + Generator.Value + ( Tuple.make_materialized + ~relation:Prelude.Catalog.branch_rel_name ~attributes, + generator )) in Relation.make ~hash:None ~name:Prelude.Catalog.branch_rel_name ~schema ~tree:None ~constraints:None @@ -115,16 +110,17 @@ module Make (Storage : Physical.S with type error = string) = struct let generator position = match position with | None -> Generator.Error "random access not supported for sakura:head" - | Some 0 -> - (match get_head storage with - | Ok None | Error _ -> Generator.Done - | Ok (Some branch_name) -> - let attributes = - Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:Prelude.Catalog.head_rel_name ~attributes - , fun _ -> Generator.Done )) + | Some 0 -> ( + match get_head storage with + | Ok None | Error _ -> Generator.Done + | Ok (Some branch_name) -> + let attributes = + Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ] + in + Generator.Value + ( Tuple.make_materialized + ~relation:Prelude.Catalog.head_rel_name ~attributes, + fun _ -> Generator.Done )) | Some _ -> Generator.Done in Relation.make ~hash:None ~name:Prelude.Catalog.head_rel_name ~schema @@ -134,5 +130,4 @@ module Make (Storage : Physical.S with type error = string) = struct ~membership_criteria:(fun _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name) ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) - end diff --git a/lib/management/merge.ml b/lib/management/merge.ml index e50d0e6..d30545a 100644 --- a/lib/management/merge.ml +++ b/lib/management/merge.ml @@ -1,40 +1,37 @@ -(** 3-way merge of two branch tips using their Lowest Common Ancestor. - Walks the history chain to find it, diffs both sides against it, - applies merge rules, validates constraints, and persists the result. *) +(** 3-way merge of two branch tips using their Lowest Common Ancestor. Walks the + history chain to find it, diffs both sides against it, applies merge rules, + validates constraints, and persists the result. *) type conflict = - | TupleConflict of { relation: string; hash: Conventions.Hash.t } - | SchemaConflict of string + | TupleConflict of { relation : string; hash : Conventions.Hash.t } + | SchemaConflict of string | ConstraintConflict of string type strategy = PreferLeft | PreferRight | RevertToAncestor - -type merge_result = - | Clean of Database.t - | Failed of conflict list +type merge_result = Clean of Database.t | Failed of conflict list (** Module type for the subset of Manipulation.Make we need. *) module type MANIPULATION = sig type storage type error - val of_string_error : string -> error - val load_database : storage -> Conventions.Hash.t -> (Database.t option, error) result + + val of_string_error : string -> error + + val load_database : + storage -> Conventions.Hash.t -> (Database.t option, error) result + val store_database : storage -> Database.t -> (unit, error) result end -module StringSet = Set.Make(String) +module StringSet = Set.Make (String) (** Walk history to find LCA. First hash in right's ancestry that also appears in left's ancestry set. *) let find_lca left_db right_db = let left_ancestors = - StringSet.of_list (left_db.Database.hash - :: left_db.Database.history) - in - let right_chain = - right_db.Database.hash - :: right_db.Database.history + StringSet.of_list (left_db.Database.hash :: left_db.Database.history) in + let right_chain = right_db.Database.hash :: right_db.Database.history in List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain (** Apply a single relation diff to a database, using strategy on conflicts. *) @@ -42,104 +39,140 @@ let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff) ~(right_diff : Diff.relation_diff option) : Database.t * conflict list = match left_diff with | Diff.RelationAdded rel -> - (* Only left added it; right_diff must be None or same *) - (Database.add_relation db ~relation:rel, []) - - | Diff.RelationRemoved name -> - (Database.remove_relation db ~name, []) - - | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } -> - let conflicts = ref [] in - (* Determine the merged relation's Merkle tree *) - let base_rel_opt = Database.get_relation db name in - (match base_rel_opt with - | None -> (db, []) - | Some base_rel -> - let base_tree = Option.value base_rel.Relation.tree ~default:Merkle.empty in - (* Handle schema conflict *) - let (resolved_rel, schema_conflict) = - if schema_changed then - match right_diff with - | Some (Diff.RelationModified { schema_changed = true; _ }) -> - (* Both changed schema — apply strategy *) - let winner = match strategy with - | PreferLeft -> Database.get_relation left_db name - | PreferRight -> Database.get_relation right_db name - | RevertToAncestor -> Some base_rel - in - (Option.value winner ~default:base_rel, [SchemaConflict name]) - | _ -> - (* Only left changed schema — take left's relation *) - let left_rel = Option.value - (Database.get_relation left_db name) ~default:base_rel in - (left_rel, []) - else (base_rel, []) - in - conflicts := schema_conflict @ !conflicts; - (* Apply tuple adds/removes from left *) - let merged_tree = - List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples - in - let merged_tree = - List.fold_left (fun t h -> Merkle.delete h t) merged_tree removed_tuples - in - (* Apply tuple adds/removes from right if disjoint *) - let merged_tree = match right_diff with - | Some (Diff.RelationModified + (* Only left added it; right_diff must be None or same *) + (Database.add_relation db ~relation:rel, []) + | Diff.RelationRemoved name -> (Database.remove_relation db ~name, []) + | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } + -> ( + let conflicts = ref [] in + (* Determine the merged relation's Merkle tree *) + let base_rel_opt = Database.get_relation db name in + match base_rel_opt with + | None -> (db, []) + | Some base_rel -> + let base_tree = + Option.value base_rel.Relation.tree ~default:Merkle.empty + in + (* Handle schema conflict *) + let resolved_rel, schema_conflict = + if schema_changed then + match right_diff with + | Some (Diff.RelationModified { schema_changed = true; _ }) -> + (* Both changed schema — apply strategy *) + let winner = + match strategy with + | PreferLeft -> Database.get_relation left_db name + | PreferRight -> Database.get_relation right_db name + | RevertToAncestor -> Some base_rel + in + ( Option.value winner ~default:base_rel, + [ SchemaConflict name ] ) + | _ -> + (* Only left changed schema — take left's relation *) + let left_rel = + Option.value + (Database.get_relation left_db name) + ~default:base_rel + in + (left_rel, []) + else (base_rel, []) + in + conflicts := schema_conflict @ !conflicts; + (* Apply tuple adds/removes from left *) + let merged_tree = + List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples + in + let merged_tree = + List.fold_left + (fun t h -> Merkle.delete h t) + merged_tree removed_tuples + in + (* Apply tuple adds/removes from right if disjoint *) + let merged_tree = + match right_diff with + | Some + (Diff.RelationModified { added_tuples = r_add; removed_tuples = r_rem; _ }) -> - (* Detect tuple conflicts: same hash both added and removed *) - let left_add = StringSet.of_list added_tuples in - let left_rem = StringSet.of_list removed_tuples in - let right_add = StringSet.of_list r_add in - let right_rem = StringSet.of_list r_rem in - let conflict_hashes = - StringSet.inter left_add right_rem - |> StringSet.union (StringSet.inter left_rem right_add) - in - if not (StringSet.is_empty conflict_hashes) then begin - StringSet.iter (fun h -> - conflicts := TupleConflict { relation = name; hash = h } :: !conflicts - ) conflict_hashes; - (* Resolve conflicting tuples per strategy *) - match strategy with - | PreferLeft -> - (* keep left's merged_tree as-is, ignore conflicting right ops *) - let safe_add = StringSet.diff right_add conflict_hashes in - let safe_rem = StringSet.diff right_rem conflict_hashes in - let t = StringSet.fold (fun h acc -> Merkle.insert h acc) safe_add merged_tree in - StringSet.fold (fun h acc -> Merkle.delete h acc) safe_rem t - | PreferRight -> - (* revert left's conflicting ops, apply right's *) - let t = StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree in - let t = StringSet.fold (fun h acc -> Merkle.insert h acc) right_add t in - StringSet.fold (fun h acc -> Merkle.delete h acc) right_rem t - | RevertToAncestor -> - (* drop conflicting hashes from merged tree *) - StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree - end else begin - (* Disjoint — union both sides *) - let t = List.fold_left (fun acc h -> Merkle.insert h acc) merged_tree r_add in - List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem - end - | _ -> merged_tree - in - let new_hash = Hashing.hash_relation - ~name:resolved_rel.Relation.name - ~schema:resolved_rel.Relation.schema - ~tree:merged_tree - in - let updated_rel = { resolved_rel with - Relation.tree = Some merged_tree; - hash = Some new_hash; - } in - let new_db = Database.update_relation db ~relation:updated_rel in - (new_db, !conflicts)) + (* Detect tuple conflicts: same hash both added and removed *) + let left_add = StringSet.of_list added_tuples in + let left_rem = StringSet.of_list removed_tuples in + let right_add = StringSet.of_list r_add in + let right_rem = StringSet.of_list r_rem in + let conflict_hashes = + StringSet.inter left_add right_rem + |> StringSet.union (StringSet.inter left_rem right_add) + in + if not (StringSet.is_empty conflict_hashes) then begin + StringSet.iter + (fun h -> + conflicts := + TupleConflict { relation = name; hash = h } + :: !conflicts) + conflict_hashes; + (* Resolve conflicting tuples per strategy *) + match strategy with + | PreferLeft -> + (* keep left's merged_tree as-is, ignore conflicting right ops *) + let safe_add = StringSet.diff right_add conflict_hashes in + let safe_rem = StringSet.diff right_rem conflict_hashes in + let t = + StringSet.fold + (fun h acc -> Merkle.insert h acc) + safe_add merged_tree + in + StringSet.fold + (fun h acc -> Merkle.delete h acc) + safe_rem t + | PreferRight -> + (* revert left's conflicting ops, apply right's *) + let t = + StringSet.fold + (fun h acc -> Merkle.delete h acc) + conflict_hashes merged_tree + in + let t = + StringSet.fold + (fun h acc -> Merkle.insert h acc) + right_add t + in + StringSet.fold + (fun h acc -> Merkle.delete h acc) + right_rem t + | RevertToAncestor -> + (* drop conflicting hashes from merged tree *) + StringSet.fold + (fun h acc -> Merkle.delete h acc) + conflict_hashes merged_tree + end + else begin + (* Disjoint — union both sides *) + let t = + List.fold_left + (fun acc h -> Merkle.insert h acc) + merged_tree r_add + in + List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem + end + | _ -> merged_tree + in + let new_hash = + Hashing.hash_relation ~name:resolved_rel.Relation.name + ~schema:resolved_rel.Relation.schema ~tree:merged_tree + in + let updated_rel = + { + resolved_rel with + Relation.tree = Some merged_tree; + hash = Some new_hash; + } + in + let new_db = Database.update_relation db ~relation:updated_rel in + (new_db, !conflicts)) module Make (Storage : Physical.S) - (Manip : MANIPULATION with type storage = Storage.t) = + (Manip : MANIPULATION with type storage = Storage.t) = struct - let err s = Error (Manip.of_string_error s) (* Load both tips, find the lowest common ancestor, compute the diffs, @@ -151,85 +184,103 @@ struct match Manip.load_database storage left_tip with | Error e -> Error e | Ok None -> err ("Left tip not found: " ^ left_tip) - | Ok (Some left_db) -> - match Manip.load_database storage right_tip with - | Error e -> Error e - | Ok None -> err ("Right tip not found: " ^ right_tip) - | Ok (Some right_db) -> - match find_lca left_db right_db with - | None -> err "No common ancestor found between branches" - | Some ancestor_hash -> - match Manip.load_database storage ancestor_hash with - | Error e -> Error e - | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) - | Ok (Some ancestor_db) -> - let left_diffs = Diff.diff ~ancestor:ancestor_db ~target:left_db in - let right_diffs = Diff.diff ~ancestor:ancestor_db ~target:right_db in - let right_diff_map = - List.fold_left (fun m d -> - let key = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - Database.RelationMap.add key d m - ) Database.RelationMap.empty right_diffs - in - let (merged_db, all_conflicts) = - let (db_after_left, left_conflicts) = - List.fold_left (fun (db, conflicts) left_d -> - let rel_name = match left_d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - let right_d = Database.RelationMap.find_opt rel_name right_diff_map in - let (new_db, cs) = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:left_d ~right_diff:right_d - in - (new_db, cs @ conflicts) - ) (ancestor_db, []) left_diffs - in - let left_names = - List.fold_left (fun s d -> - let n = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - StringSet.add n s - ) StringSet.empty left_diffs - in - let right_only = List.filter (fun d -> - let n = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - not (StringSet.mem n left_names) - ) right_diffs in - let (db_final, right_conflicts) = - List.fold_left (fun (db, conflicts) right_d -> - let (new_db, cs) = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:right_d ~right_diff:None - in - (new_db, cs @ conflicts) - ) (db_after_left, left_conflicts) right_only - in - (db_final, right_conflicts) - in - let unresolvable = List.filter (function - | ConstraintConflict _ -> true - | _ -> false - ) all_conflicts in - if unresolvable <> [] then - Ok (Failed unresolvable) - else begin - match Manip.store_database storage merged_db with - | Error e -> Error e - | Ok () -> Ok (Clean merged_db) - end - + | Ok (Some left_db) -> ( + match Manip.load_database storage right_tip with + | Error e -> Error e + | Ok None -> err ("Right tip not found: " ^ right_tip) + | Ok (Some right_db) -> ( + match find_lca left_db right_db with + | None -> err "No common ancestor found between branches" + | Some ancestor_hash -> ( + match Manip.load_database storage ancestor_hash with + | Error e -> Error e + | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) + | Ok (Some ancestor_db) -> + let left_diffs = + Diff.diff ~ancestor:ancestor_db ~target:left_db + in + let right_diffs = + Diff.diff ~ancestor:ancestor_db ~target:right_db + in + let right_diff_map = + List.fold_left + (fun m d -> + let key = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + Database.RelationMap.add key d m) + Database.RelationMap.empty right_diffs + in + let merged_db, all_conflicts = + let db_after_left, left_conflicts = + List.fold_left + (fun (db, conflicts) left_d -> + let rel_name = + match left_d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + let right_d = + Database.RelationMap.find_opt rel_name + right_diff_map + in + let new_db, cs = + apply_diff db ~strategy ~left_db ~right_db + ~left_diff:left_d ~right_diff:right_d + in + (new_db, cs @ conflicts)) + (ancestor_db, []) left_diffs + in + let left_names = + List.fold_left + (fun s d -> + let n = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + StringSet.add n s) + StringSet.empty left_diffs + in + let right_only = + List.filter + (fun d -> + let n = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + not (StringSet.mem n left_names)) + right_diffs + in + let db_final, right_conflicts = + List.fold_left + (fun (db, conflicts) right_d -> + let new_db, cs = + apply_diff db ~strategy ~left_db ~right_db + ~left_diff:right_d ~right_diff:None + in + (new_db, cs @ conflicts)) + (db_after_left, left_conflicts) + right_only + in + (db_final, right_conflicts) + in + let unresolvable = + List.filter + (function ConstraintConflict _ -> true | _ -> false) + all_conflicts + in + if unresolvable <> [] then Ok (Failed unresolvable) + else begin + match Manip.store_database storage merged_db with + | Error e -> Error e + | Ok () -> Ok (Clean merged_db) + end))) end diff --git a/lib/management/physical.ml b/lib/management/physical.ml index 6063d79..3fc2cf7 100644 --- a/lib/management/physical.ml +++ b/lib/management/physical.ml @@ -1,46 +1,48 @@ (** Physical storage abstraction. - This module defines a functor-based storage interface that can be backed - by any key-value store (etcd, Redis, DynamoDB, PostgreSQL, filesystem, etc.). + This module defines a functor-based storage interface that can be backed by + any key-value store (etcd, Redis, DynamoDB, PostgreSQL, filesystem, etc.). - All data is content-addressed: keys are hashes, values are serialized objects. - The storage is append-only - objects are never modified, only new versions - are written with new hashes. *) + All data is content-addressed: keys are hashes, values are serialized + objects. The storage is append-only - objects are never modified, only new + versions are written with new hashes. *) (** Backend module signature that any storage driver must implement *) module type BACKEND = sig type connection type error - (** Connect to the storage backend *) val connect : unit -> (connection, error) result + (** Connect to the storage backend *) - (** Disconnect from the backend *) val disconnect : connection -> unit + (** Disconnect from the backend *) - (** Get a value by its hash. Returns None if not found. *) val get : connection -> Conventions.Hash.t -> (bytes option, error) result + (** Get a value by its hash. Returns None if not found. *) - (** Store a value at its hash *) val put : connection -> Conventions.Hash.t -> bytes -> (unit, error) result + (** Store a value at its hash *) - (** Check if a hash exists *) val exists : connection -> Conventions.Hash.t -> (bool, error) result + (** Check if a hash exists *) - (** Begin a transaction *) val begin_transaction : connection -> (unit, error) result + (** Begin a transaction *) - (** Commit a transaction *) val commit : connection -> (unit, error) result + (** Commit a transaction *) - (** Rollback a transaction *) val rollback : connection -> (unit, error) result + (** Rollback a transaction *) + val get_many : + connection -> Conventions.Hash.t list -> (bytes option list, error) result (** Batch get multiple values *) - val get_many : connection -> Conventions.Hash.t list -> (bytes option list, error) result + val put_many : + connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result (** Batch put multiple values *) - val put_many : connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result end (** Storage operations built on top of a backend *) @@ -48,29 +50,33 @@ module type S = sig type t type error - (** Create a storage instance from a backend connection *) val create : unit -> (t, error) result + (** Create a storage instance from a backend connection *) - (** Close the storage *) val close : t -> unit + (** Close the storage *) + val store_attribute : + t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result (** Store an attribute value, returns its hash *) - val store_attribute : t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result + val load_attribute : + t -> + Conventions.Hash.t -> + (Conventions.AbstractValue.t option, error) result (** Load an attribute value by hash *) - val load_attribute : t -> Conventions.Hash.t -> (Conventions.AbstractValue.t option, error) result - (** Store raw bytes at a hash *) val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, error) result + (** Store raw bytes at a hash *) - (** Load raw bytes by hash *) val load_raw : t -> Conventions.Hash.t -> (bytes option, error) result + (** Load raw bytes by hash *) - (** Check if a hash exists *) val exists : t -> Conventions.Hash.t -> (bool, error) result + (** Check if a hash exists *) - (** Execute a function within a transaction *) val with_transaction : t -> (unit -> ('a, error) result) -> ('a, error) result + (** Execute a function within a transaction *) end (** Functor to create storage operations from a backend *) @@ -79,15 +85,12 @@ module Make (B : BACKEND) : S with type error = B.error = struct type error = B.error let create () = B.connect () - let close = B.disconnect let store_attribute conn value = let bytes = Marshal.to_bytes value [] in let hash = Conventions.AbstractValue.hash value in - match B.put conn hash bytes with - | Ok () -> Ok hash - | Error e -> Error e + match B.put conn hash bytes with Ok () -> Ok hash | Error e -> Error e let load_attribute conn hash = match B.get conn hash with @@ -95,27 +98,20 @@ module Make (B : BACKEND) : S with type error = B.error = struct | Ok None -> Ok None | Error e -> Error e - let store_raw conn hash bytes = - B.put conn hash bytes - - let load_raw conn hash = - B.get conn hash - - let exists conn hash = - B.exists conn hash + let store_raw conn hash bytes = B.put conn hash bytes + let load_raw conn hash = B.get conn hash + let exists conn hash = B.exists conn hash let with_transaction conn f = match B.begin_transaction conn with | Error e -> Error e - | Ok () -> - match f () with - | Ok result -> - (match B.commit conn with - | Ok () -> Ok result - | Error e -> Error e) - | Error e -> - let _ = B.rollback conn in - Error e + | Ok () -> ( + match f () with + | Ok result -> ( + match B.commit conn with Ok () -> Ok result | Error e -> Error e) + | Error e -> + let _ = B.rollback conn in + Error e) end (** In-memory backend for testing and development *) @@ -125,35 +121,34 @@ module MemoryBackend : BACKEND with type error = string = struct mutable in_transaction : bool; mutable transaction_buffer : (string * bytes) list; } + type error = string let connect () = - Ok { - data = Hashtbl.create 1024; - in_transaction = false; - transaction_buffer = []; - } + Ok + { + data = Hashtbl.create 1024; + in_transaction = false; + transaction_buffer = []; + } let disconnect _ = () - - let get conn hash = - Ok (Hashtbl.find_opt conn.data hash) + let get conn hash = Ok (Hashtbl.find_opt conn.data hash) let put conn hash value = if conn.in_transaction then begin conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer; Ok () - end else begin + end + else begin Hashtbl.replace conn.data hash value; Ok () end - let exists conn hash = - Ok (Hashtbl.mem conn.data hash) + let exists conn hash = Ok (Hashtbl.mem conn.data hash) let begin_transaction conn = - if conn.in_transaction then - Error "Already in transaction" + if conn.in_transaction then Error "Already in transaction" else begin conn.in_transaction <- true; conn.transaction_buffer <- []; @@ -161,20 +156,18 @@ module MemoryBackend : BACKEND with type error = string = struct end let commit conn = - if not conn.in_transaction then - Error "Not in transaction" + if not conn.in_transaction then Error "Not in transaction" else begin - List.iter (fun (hash, value) -> - Hashtbl.replace conn.data hash value - ) conn.transaction_buffer; + List.iter + (fun (hash, value) -> Hashtbl.replace conn.data hash value) + conn.transaction_buffer; conn.in_transaction <- false; conn.transaction_buffer <- []; Ok () end let rollback conn = - if not conn.in_transaction then - Error "Not in transaction" + if not conn.in_transaction then Error "Not in transaction" else begin conn.in_transaction <- false; conn.transaction_buffer <- []; @@ -185,14 +178,14 @@ module MemoryBackend : BACKEND with type error = string = struct Ok (List.map (fun h -> Hashtbl.find_opt conn.data h) hashes) let put_many conn pairs = - List.iter (fun (hash, value) -> - if conn.in_transaction then - conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer - else - Hashtbl.replace conn.data hash value - ) pairs; + List.iter + (fun (hash, value) -> + if conn.in_transaction then + conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer + else Hashtbl.replace conn.data hash value) + pairs; Ok () end +module Memory = Make (MemoryBackend) (** Default in-memory storage for development *) -module Memory = Make(MemoryBackend) diff --git a/lib/merkle.ml b/lib/merkle.ml index ffa7171..6c4be52 100644 --- a/lib/merkle.ml +++ b/lib/merkle.ml @@ -2,57 +2,52 @@ This is an opaque interface that can be backed by different implementations: - A simple hash set (current placeholder) - - A proper radix/patricia merkle tree (e.g., plebeia when OCaml 5 support arrives) + - A proper radix/patricia merkle tree (e.g., plebeia when OCaml 5 support + arrives) - The tree stores hashes as keys (like a set) and computes a root hash - from all contained elements. *) + The tree stores hashes as keys (like a set) and computes a root hash from + all contained elements. *) module type S = sig type t - (** The empty tree *) val empty : t + (** The empty tree *) - (** Check if tree is empty *) val is_empty : t -> bool + (** Check if tree is empty *) - (** Insert a hash into the tree. Returns a new tree. *) val insert : Conventions.Hash.t -> t -> t + (** Insert a hash into the tree. Returns a new tree. *) - (** Delete a hash from the tree. Returns a new tree. *) val delete : Conventions.Hash.t -> t -> t + (** Delete a hash from the tree. Returns a new tree. *) - (** Check if a hash is in the tree *) val member : Conventions.Hash.t -> t -> bool + (** Check if a hash is in the tree *) - (** Get all hashes in the tree *) val keys : t -> Conventions.Hash.t list + (** Get all hashes in the tree *) - (** Compute the root hash of the tree. None if empty. *) val root_hash : t -> Conventions.Hash.t option + (** Compute the root hash of the tree. None if empty. *) - (** Number of elements in the tree *) val size : t -> int + (** Number of elements in the tree *) end -(** Simple hash set implementation. - This is a placeholder until a proper radix-merkle library - with OCaml 5 support becomes available. *) +(** Simple hash set implementation. This is a placeholder until a proper + radix-merkle library with OCaml 5 support becomes available. *) module HashSet : S = struct - module StringSet = Set.Make(String) + module StringSet = Set.Make (String) type t = StringSet.t let empty = StringSet.empty - let is_empty = StringSet.is_empty - let insert hash tree = StringSet.add hash tree - let delete hash tree = StringSet.remove hash tree - let member hash tree = StringSet.mem hash tree - let keys tree = StringSet.elements tree (* TODO: Streaming/pagination for large tuple sets. Currently materializes entire keyset into memory, which fails for relations with billions of tuples. @@ -60,10 +55,8 @@ module HashSet : S = struct to avoid loading all hashes upfront. Consider replacing HashSet with proper radix-merkle tree (plebeia) for native lazy traversal. *) - let root_hash tree = - if StringSet.is_empty tree then - None + if StringSet.is_empty tree then None else (* Compute root hash by hashing sorted concatenation of all hashes *) let sorted_hashes = StringSet.elements tree in @@ -73,5 +66,5 @@ module HashSet : S = struct let size = StringSet.cardinal end -(** Default implementation using HashSet *) include HashSet +(** Default implementation using HashSet *) diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml index 4a7241a..ce36f1e 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -1,39 +1,35 @@ -(** System catalog helpers. - Pure definitions — no storage access, no manipulation dependency. - Consumed by {!Manipulation.Make} to bootstrap and maintain the six - catalog relations that make the database self-describing. *) +(** System catalog helpers. Pure definitions — no storage access, no + manipulation dependency. Consumed by {!Manipulation.Make} to bootstrap and + maintain the six catalog relations that make the database self-describing. +*) (* TODO: on_rel_name and timing_rel_name are defined and seeded but never written to by any executor. They appear to be stubs for trigger/timing metadata that was never implemented. *) let catalog_prefix = "sakura:" - -let relation_rel_name = catalog_prefix ^ "relation" -let domain_rel_name = catalog_prefix ^ "domain" -let attribute_rel_name = catalog_prefix ^ "attribute" +let relation_rel_name = catalog_prefix ^ "relation" +let domain_rel_name = catalog_prefix ^ "domain" +let attribute_rel_name = catalog_prefix ^ "attribute" let constraint_rel_name = catalog_prefix ^ "constraint" -let on_rel_name = catalog_prefix ^ "on" -let timing_rel_name = catalog_prefix ^ "timing" -let branch_rel_name = catalog_prefix ^ "branch" -let head_rel_name = catalog_prefix ^ "head" +let on_rel_name = catalog_prefix ^ "on" +let timing_rel_name = catalog_prefix ^ "timing" +let branch_rel_name = catalog_prefix ^ "branch" +let head_rel_name = catalog_prefix ^ "head" let catalog_relation_names = - [ relation_rel_name - ; domain_rel_name - ; attribute_rel_name - ; constraint_rel_name - ; on_rel_name - ; timing_rel_name + [ + relation_rel_name; + domain_rel_name; + attribute_rel_name; + constraint_rel_name; + on_rel_name; + timing_rel_name; ] let is_catalog_relation name = List.mem name catalog_relation_names - -let relation_schema : Schema.t = - Schema.empty |> Schema.add "name" "string" - -let domain_schema : Schema.t = - Schema.empty |> Schema.add "name" "string" +let relation_schema : Schema.t = Schema.empty |> Schema.add "name" "string" +let domain_schema : Schema.t = Schema.empty |> Schema.add "name" "string" let attribute_schema : Schema.t = Schema.empty @@ -42,23 +38,20 @@ let attribute_schema : Schema.t = |> Schema.add "domain_name" "string" let constraint_schema : Schema.t = - Schema.empty - |> Schema.add "name" "string" + Schema.empty |> Schema.add "name" "string" |> Schema.add "relation_name" "string" -let on_schema : Schema.t = - Schema.empty |> Schema.add "event" "string" - -let timing_schema : Schema.t = - Schema.empty |> Schema.add "timing" "string" +let on_schema : Schema.t = Schema.empty |> Schema.add "event" "string" +let timing_schema : Schema.t = Schema.empty |> Schema.add "timing" "string" let catalog_definitions = - [ (relation_rel_name, relation_schema) - ; (domain_rel_name, domain_schema) - ; (attribute_rel_name, attribute_schema) - ; (constraint_rel_name, constraint_schema) - ; (on_rel_name, on_schema) - ; (timing_rel_name, timing_schema) + [ + (relation_rel_name, relation_schema); + (domain_rel_name, domain_schema); + (attribute_rel_name, attribute_schema); + (constraint_rel_name, constraint_schema); + (on_rel_name, on_schema); + (timing_rel_name, timing_schema); ] (* TODO: all tuple builders use Obj.magic to coerce string values into @@ -66,51 +59,59 @@ let catalog_definitions = should use Obj.repr instead. *) let build_relation_tuple rel_name : Tuple.materialized = - { Tuple.relation = relation_rel_name - ; attributes = + { + Tuple.relation = relation_rel_name; + attributes = Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic rel_name } + { Attribute.value = Obj.magic rel_name }; } let build_domain_tuple dom_name : Tuple.materialized = - { Tuple.relation = domain_rel_name - ; attributes = + { + Tuple.relation = domain_rel_name; + attributes = Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic dom_name } + { Attribute.value = Obj.magic dom_name }; } -let build_attribute_tuples ~relation_name (schema : Schema.t) : Tuple.materialized list = - List.map (fun (attr_n, dom_n) -> - { Tuple.relation = attribute_rel_name - ; attributes = - Tuple.AttributeMap.of_list - [ ("relation_name", { Attribute.value = Obj.magic relation_name }) - ; ("attr_name", { Attribute.value = Obj.magic attr_n }) - ; ("domain_name", { Attribute.value = Obj.magic dom_n }) - ] - } - ) schema +let build_attribute_tuples ~relation_name (schema : Schema.t) : + Tuple.materialized list = + List.map + (fun (attr_n, dom_n) -> + { + Tuple.relation = attribute_rel_name; + attributes = + Tuple.AttributeMap.of_list + [ + ("relation_name", { Attribute.value = Obj.magic relation_name }); + ("attr_name", { Attribute.value = Obj.magic attr_n }); + ("domain_name", { Attribute.value = Obj.magic dom_n }); + ]; + }) + schema let build_constraint_tuple cname rel_name : Tuple.materialized = - { Tuple.relation = constraint_rel_name - ; attributes = + { + Tuple.relation = constraint_rel_name; + attributes = Tuple.AttributeMap.of_list - [ ("name", { Attribute.value = Obj.magic cname }) - ; ("relation_name", { Attribute.value = Obj.magic rel_name }) - ] + [ + ("name", { Attribute.value = Obj.magic cname }); + ("relation_name", { Attribute.value = Obj.magic rel_name }); + ]; } let build_on_tuple event : Tuple.materialized = - { Tuple.relation = on_rel_name - ; attributes = - Tuple.AttributeMap.singleton "event" - { Attribute.value = Obj.magic event } + { + Tuple.relation = on_rel_name; + attributes = + Tuple.AttributeMap.singleton "event" { Attribute.value = Obj.magic event }; } let build_timing_tuple timing : Tuple.materialized = - { Tuple.relation = timing_rel_name - ; attributes = + { + Tuple.relation = timing_rel_name; + attributes = Tuple.AttributeMap.singleton "timing" - { Attribute.value = Obj.magic timing } + { Attribute.value = Obj.magic timing }; } - diff --git a/lib/prelude/domains.ml b/lib/prelude/domains.ml index 29104bb..d892696 100644 --- a/lib/prelude/domains.ml +++ b/lib/prelude/domains.ml @@ -1,21 +1,19 @@ -(** Predefined fundamental domains, ported from the Erlang implementation. - Each domain carries a generator (for enumeration) and membership criteria - (for validation). Values are stored as {!Conventions.AbstractValue.t} via +(** Predefined fundamental domains, ported from the Erlang implementation. Each + domain carries a generator (for enumeration) and membership criteria (for + validation). Values are stored as {!Conventions.AbstractValue.t} via [Obj.magic], following the same convention as {!Standard}. *) (** Bijection from natural number to integer: 0→0, 1→1, 2→-1, 3→2, 4→-2, … *) let nat_to_int n = - if n = 0 then 0 - else if n mod 2 = 1 then (n + 1) / 2 - else -(n / 2) + if n = 0 then 0 else if n mod 2 = 1 then (n + 1) / 2 else -(n / 2) (** Cantor pairing inverse: given position [n], returns a pair [(a, b)] of natural numbers such that [a + b] lies on the [n]-th diagonal. *) let cantor_unpair n = let w = - int_of_float (floor ((sqrt (float_of_int (8 * n + 1)) -. 1.) /. 2.)) + int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) in - let t = (w * (w + 1)) / 2 in + let t = w * (w + 1) / 2 in let b = n - t in let a = w - b in (a, b) @@ -26,84 +24,84 @@ let integer : Domain.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let v = nat_to_int n in - let attributes = Tuple.AttributeMap.of_list [ ("value", Obj.magic v) ] in - Generator.Value - (Tuple.make_materialized ~relation:"integer" ~attributes, generator) + let v = nat_to_int n in + let attributes = + Tuple.AttributeMap.of_list [ ("value", Obj.magic v) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"integer" ~attributes, generator) | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the integer domain." + Generator.Error + "Cannot produce a randomly enumerated value for the integer domain." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized _ -> true | Tuple.NonMaterialized _ -> false in Domain.make ~name:"integer" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> + Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) -(** Natural number domain: non-negative integers (0, 1, 2, …). - Schema: [value: natural]. *) +(** Natural number domain: non-negative integers (0, 1, 2, …). Schema: + [value: natural]. *) let natural : Domain.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let attributes = Tuple.AttributeMap.of_list [ ("value", Obj.magic n) ] in - Generator.Value - (Tuple.make_materialized ~relation:"natural" ~attributes, generator) + let attributes = + Tuple.AttributeMap.of_list [ ("value", Obj.magic n) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"natural" ~attributes, generator) | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the natural domain." + Generator.Error + "Cannot produce a randomly enumerated value for the natural domain." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match Tuple.AttributeMap.find_opt "value" m.attributes with - | Some attr -> (Obj.magic attr : int) >= 0 - | None -> false) + match Tuple.AttributeMap.find_opt "value" m.attributes with + | Some attr -> (Obj.magic attr : int) >= 0 + | None -> false) | Tuple.NonMaterialized _ -> false in Domain.make ~name:"natural" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> + Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) (** Rational number domain: pairs [(numerator, denominator)] where the - denominator is never zero. The generator enumerates all such pairs via - Cantor pairing on the integers. - Schema: [numerator: integer, denominator: integer]. *) + denominator is never zero. The generator enumerates all such pairs via + Cantor pairing on the integers. Schema: + [numerator: integer, denominator: integer]. *) let rational : Domain.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_unpair n in - let num = nat_to_int a in - (* Map b → non-zero integer: 0→1, 1→-1, 2→2, 3→-2, … *) - let den = - if b mod 2 = 0 then b / 2 + 1 else -((b + 1) / 2) - in - let attributes = - Tuple.AttributeMap.of_list - [ ("numerator", Obj.magic num); ("denominator", Obj.magic den) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"rational" ~attributes, generator) + let a, b = cantor_unpair n in + let num = nat_to_int a in + (* Map b → non-zero integer: 0→1, 1→-1, 2→2, 3→-2, … *) + let den = if b mod 2 = 0 then (b / 2) + 1 else -((b + 1) / 2) in + let attributes = + Tuple.AttributeMap.of_list + [ ("numerator", Obj.magic num); ("denominator", Obj.magic den) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"rational" ~attributes, generator) | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the rational domain." + Generator.Error + "Cannot produce a randomly enumerated value for the rational domain." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match Tuple.AttributeMap.find_opt "denominator" m.attributes with - | Some attr -> (Obj.magic attr : int) <> 0 - | None -> false) + match Tuple.AttributeMap.find_opt "denominator" m.attributes with + | Some attr -> (Obj.magic attr : int) <> 0 + | None -> false) | Tuple.NonMaterialized _ -> false in Domain.make ~name:"rational" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> Stdlib.compare (Obj.magic a : float) (Obj.magic b : float)) -(** String domain: any string value. Not enumerable. - Schema: [value: string]. *) +(** String domain: any string value. Not enumerable. Schema: [value: string]. *) let string : Domain.t = let generator (_ : int option) : Generator.result = Generator.Error "Strings are not enumerable." @@ -113,6 +111,5 @@ let string : Domain.t = | Tuple.NonMaterialized _ -> false in Domain.make ~name:"string" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> String.compare (Obj.magic a : string) (Obj.magic b : string)) diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml index 68012fc..6bdab0c 100644 --- a/lib/prelude/standard.ml +++ b/lib/prelude/standard.ml @@ -7,22 +7,23 @@ let mk v = { Attribute.value = Obj.repr v } -(** Build a comparison relation over a single domain. - [pred] receives the result of [Stdlib.compare left right]. *) +(** Build a comparison relation over a single domain. [pred] receives the result + of [Stdlib.compare left right]. *) let make_comparison ~name ~domain_name ~pred ~cardinality ~generator = let schema = - Schema.empty |> Schema.add "left" domain_name + Schema.empty + |> Schema.add "left" domain_name |> Schema.add "right" domain_name in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "left" m.attributes, - Tuple.AttributeMap.find_opt "right" m.attributes ) - with - | Some l, Some r -> - pred (Stdlib.compare l.Attribute.value r.Attribute.value) - | _ -> false) + match + ( Tuple.AttributeMap.find_opt "left" m.attributes, + Tuple.AttributeMap.find_opt "right" m.attributes ) + with + | Some l, Some r -> + pred (Stdlib.compare l.Attribute.value r.Attribute.value) + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name ~schema ~tree:None ~constraints:None @@ -33,38 +34,35 @@ let make_comparison ~name ~domain_name ~pred ~cardinality ~generator = (** Enumerate pairs (a, b) where a < b using triangular indexing. *) let pair_of_nat_lt n = let nf = float_of_int n in - let r = int_of_float (floor ((1. +. sqrt (1. +. 8. *. nf)) /. 2.)) in - let t_prev = (r * (r - 1)) / 2 in + let r = int_of_float (floor ((1. +. sqrt (1. +. (8. *. nf))) /. 2.)) in + let t_prev = r * (r - 1) / 2 in let left = n - t_prev in (left, r) (** Enumerate all pairs (a, b) via Cantor pairing. *) let cantor_pair_of_nat n = let w = - int_of_float (floor ((sqrt (float_of_int (8 * n + 1)) -. 1.) /. 2.)) + int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) in - let t = (w * (w + 1)) / 2 in + let t = w * (w + 1) / 2 in let b = n - t in let a = w - b in (a, b) - let less_than_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some position -> - let left, right = pair_of_nat_lt position in - let attributes : Attribute.materialized Tuple.AttributeMap.t = - Tuple.AttributeMap.of_list - [ ("left", mk left); ("right", mk right) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"less_than" ~attributes, - generator ) + let left, right = pair_of_nat_lt position in + let attributes : Attribute.materialized Tuple.AttributeMap.t = + Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"less_than" ~attributes, generator) | None -> - Error - "Cannot produce a randomly enumerated value for less_than over \ - naturals." + Error + "Cannot produce a randomly enumerated value for less_than over \ + naturals." in make_comparison ~name:"natural_natural_less_than" ~domain_name:"natural" ~pred:(fun c -> c < 0) @@ -74,17 +72,16 @@ let less_than_or_equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_pair_of_nat n in - (* a <= b is always true when a <= b; we enumerate all (a, b) with a <= b *) - let left = min a b in - let right = max a b in - let attributes = - Tuple.AttributeMap.of_list - [ ("left", mk left); ("right", mk right) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"less_than_or_equal" ~attributes, - generator ) + let a, b = cantor_pair_of_nat n in + (* a <= b is always true when a <= b; we enumerate all (a, b) with a <= b *) + let left = min a b in + let right = max a b in + let attributes = + Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] + in + Generator.Value + ( Tuple.make_materialized ~relation:"less_than_or_equal" ~attributes, + generator ) | None -> Error "Cannot enumerate less_than_or_equal randomly." in make_comparison ~name:"natural_natural_less_than_or_equal" @@ -96,15 +93,14 @@ let greater_than_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let left, right = pair_of_nat_lt n in - (* Swap: right > left *) - let attributes = - Tuple.AttributeMap.of_list - [ ("left", mk right); ("right", mk left) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"greater_than" ~attributes, - generator ) + let left, right = pair_of_nat_lt n in + (* Swap: right > left *) + let attributes = + Tuple.AttributeMap.of_list [ ("left", mk right); ("right", mk left) ] + in + Generator.Value + ( Tuple.make_materialized ~relation:"greater_than" ~attributes, + generator ) | None -> Error "Cannot enumerate greater_than randomly." in make_comparison ~name:"natural_natural_greater_than" ~domain_name:"natural" @@ -115,16 +111,15 @@ let greater_than_or_equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_pair_of_nat n in - let left = max a b in - let right = min a b in - let attributes = - Tuple.AttributeMap.of_list - [ ("left", mk left); ("right", mk right) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"greater_than_or_equal" ~attributes, - generator ) + let a, b = cantor_pair_of_nat n in + let left = max a b in + let right = min a b in + let attributes = + Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] + in + Generator.Value + ( Tuple.make_materialized ~relation:"greater_than_or_equal" ~attributes, + generator ) | None -> Error "Cannot enumerate greater_than_or_equal randomly." in make_comparison ~name:"natural_natural_greater_than_or_equal" @@ -136,12 +131,11 @@ let equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let attributes = - Tuple.AttributeMap.of_list - [ ("left", mk n); ("right", mk n) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"equal" ~attributes, generator ) + let attributes = + Tuple.AttributeMap.of_list [ ("left", mk n); ("right", mk n) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"equal" ~attributes, generator) | None -> Error "Cannot enumerate equal randomly." in make_comparison ~name:"natural_natural_equal" ~domain_name:"natural" @@ -152,21 +146,19 @@ let not_equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_pair_of_nat n in - let left, right = if a = b then (a, b + 1) else (a, b) in - let attributes = - Tuple.AttributeMap.of_list - [ ("left", mk left); ("right", mk right) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"not_equal" ~attributes, generator ) + let a, b = cantor_pair_of_nat n in + let left, right = if a = b then (a, b + 1) else (a, b) in + let attributes = + Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"not_equal" ~attributes, generator) | None -> Error "Cannot enumerate not_equal randomly." in make_comparison ~name:"natural_natural_not_equal" ~domain_name:"natural" ~pred:(fun c -> c <> 0) ~cardinality:Conventions.Cardinality.AlephZero ~generator - let plus_natural : Relation.t = let schema = Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" @@ -175,175 +167,159 @@ let plus_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_pair_of_nat n in - let s = a + b in - let attributes = - Tuple.AttributeMap.of_list - [ ("a", mk a); ("b", mk b); ("sum", mk s) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"plus" ~attributes, generator ) + let a, b = cantor_pair_of_nat n in + let s = a + b in + let attributes = + Tuple.AttributeMap.of_list [ ("a", mk a); ("b", mk b); ("sum", mk s) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"plus" ~attributes, generator) | None -> Error "Cannot enumerate plus randomly." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "sum" m.attributes ) - with - | Some a, Some b, Some s -> - (Obj.magic a.Attribute.value : int) - + (Obj.magic b.Attribute.value : int) - = (Obj.magic s.Attribute.value : int) - | _ -> false) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "sum" m.attributes ) + with + | Some a, Some b, Some s -> + (Obj.magic a.Attribute.value : int) + + (Obj.magic b.Attribute.value : int) + = (Obj.magic s.Attribute.value : int) + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_plus" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "plus") ~lineage:(Relation.Lineage.Base "plus") let times_natural : Relation.t = let schema = - Schema.empty |> Schema.add "a" "natural" - |> Schema.add "b" "natural" + Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" |> Schema.add "product" "natural" in let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_pair_of_nat n in - let p = a * b in - let attributes = - Tuple.AttributeMap.of_list - [ - ("a", mk a); ("b", mk b); ("product", mk p); - ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"times" ~attributes, generator ) + let a, b = cantor_pair_of_nat n in + let p = a * b in + let attributes = + Tuple.AttributeMap.of_list + [ ("a", mk a); ("b", mk b); ("product", mk p) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"times" ~attributes, generator) | None -> Error "Cannot enumerate times randomly." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "product" m.attributes ) - with - | Some a, Some b, Some p -> - (Obj.magic a.Attribute.value : int) - * (Obj.magic b.Attribute.value : int) - = (Obj.magic p.Attribute.value : int) - | _ -> false) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "product" m.attributes ) + with + | Some a, Some b, Some p -> + (Obj.magic a.Attribute.value : int) + * (Obj.magic b.Attribute.value : int) + = (Obj.magic p.Attribute.value : int) + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_times" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "times") ~lineage:(Relation.Lineage.Base "times") let minus_natural : Relation.t = let schema = - Schema.empty |> Schema.add "a" "natural" - |> Schema.add "b" "natural" + Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" |> Schema.add "difference" "natural" in let rec generator (position : int option) : Generator.result = match position with | Some n -> - (* Enumerate pairs where a >= b, so difference >= 0 *) - let b, diff = cantor_pair_of_nat n in - let a = b + diff in - let attributes = - Tuple.AttributeMap.of_list - [ - ("a", mk a); - ("b", mk b); - ("difference", mk diff); - ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"minus" ~attributes, generator ) + (* Enumerate pairs where a >= b, so difference >= 0 *) + let b, diff = cantor_pair_of_nat n in + let a = b + diff in + let attributes = + Tuple.AttributeMap.of_list + [ ("a", mk a); ("b", mk b); ("difference", mk diff) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"minus" ~attributes, generator) | None -> Error "Cannot enumerate minus randomly." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "difference" m.attributes ) - with - | Some a, Some b, Some d -> - let av = (Obj.magic a.Attribute.value : int) in - let bv = (Obj.magic b.Attribute.value : int) in - let dv = (Obj.magic d.Attribute.value : int) in - av - bv = dv && dv >= 0 - | _ -> false) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "difference" m.attributes ) + with + | Some a, Some b, Some d -> + let av = (Obj.magic a.Attribute.value : int) in + let bv = (Obj.magic b.Attribute.value : int) in + let dv = (Obj.magic d.Attribute.value : int) in + av - bv = dv && dv >= 0 + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_minus" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "minus") ~lineage:(Relation.Lineage.Base "minus") let divide_natural : Relation.t = let schema = - Schema.empty |> Schema.add "a" "natural" - |> Schema.add "b" "natural" + Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" |> Schema.add "quotient" "natural" |> Schema.add "remainder" "natural" in let rec generator (position : int option) : Generator.result = match position with | Some n -> - (* Enumerate (b, q, r) triples where b > 0, then a = b*q + r, 0 <= r < b *) - (* We use a nested Cantor pairing: n -> (b_idx, qr_idx) -> (q, r) *) - let b_idx, qr_idx = cantor_pair_of_nat n in - let b = b_idx + 1 in (* b > 0 *) - let q, r_raw = cantor_pair_of_nat qr_idx in - let r = r_raw mod b in - let a = b * q + r in - let attributes = - Tuple.AttributeMap.of_list - [ - ("a", mk a); - ("b", mk b); - ("quotient", mk q); - ("remainder", mk r); - ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"divide" ~attributes, generator ) + (* Enumerate (b, q, r) triples where b > 0, then a = b*q + r, 0 <= r < b *) + (* We use a nested Cantor pairing: n -> (b_idx, qr_idx) -> (q, r) *) + let b_idx, qr_idx = cantor_pair_of_nat n in + let b = b_idx + 1 in + (* b > 0 *) + let q, r_raw = cantor_pair_of_nat qr_idx in + let r = r_raw mod b in + let a = (b * q) + r in + let attributes = + Tuple.AttributeMap.of_list + [ + ("a", mk a); ("b", mk b); ("quotient", mk q); ("remainder", mk r); + ] + in + Generator.Value + (Tuple.make_materialized ~relation:"divide" ~attributes, generator) | None -> Error "Cannot enumerate divide randomly." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "quotient" m.attributes, - Tuple.AttributeMap.find_opt "remainder" m.attributes ) - with - | Some a, Some b, Some q, Some r -> - let av = (Obj.magic a.Attribute.value : int) in - let bv = (Obj.magic b.Attribute.value : int) in - let qv = (Obj.magic q.Attribute.value : int) in - let rv = (Obj.magic r.Attribute.value : int) in - bv > 0 && av = bv * qv + rv && rv >= 0 && rv < bv - | _ -> false) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "quotient" m.attributes, + Tuple.AttributeMap.find_opt "remainder" m.attributes ) + with + | Some a, Some b, Some q, Some r -> + let av = (Obj.magic a.Attribute.value : int) in + let bv = (Obj.magic b.Attribute.value : int) in + let qv = (Obj.magic q.Attribute.value : int) in + let rv = (Obj.magic r.Attribute.value : int) in + bv > 0 && av = (bv * qv) + rv && rv >= 0 && rv < bv + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_divide" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "divide") ~lineage:(Relation.Lineage.Base "divide") diff --git a/lib/relation.ml b/lib/relation.ml index 0773c6c..285bcef 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -1,5 +1,5 @@ -(** Use the Merkle module for tuple hash storage *) module Tree = Merkle +(** Use the Merkle module for tuple hash storage *) module RelationConstraint = struct type name = string @@ -54,4 +54,4 @@ let make ~hash ~name ~schema ~tree ~constraints ~cardinality ~generator membership_criteria; provenance; lineage; - }
\ No newline at end of file + } diff --git a/lib/schema.ml b/lib/schema.ml index e17f7a5..923284a 100644 --- a/lib/schema.ml +++ b/lib/schema.ml @@ -1,7 +1,7 @@ (** Schema: maps attribute names to domain/type names. - A schema defines the structure of a relation by listing each attribute - and its associated domain (type). This is used for: + A schema defines the structure of a relation by listing each attribute and + its associated domain (type). This is used for: - Hashing relations (schema is part of the relation identity) - Validation (checking tuple membership) - Persistence (storing and loading relations with their structure) *) @@ -9,13 +9,8 @@ type t = (string * string) list let empty : t = [] - -let add name domain_name (schema : t) : t = - (name, domain_name) :: schema - -let attributes (schema : t) = - List.map fst schema +let add name domain_name (schema : t) : t = (name, domain_name) :: schema +let attributes (schema : t) = List.map fst schema let to_string schema = - List.map (fun (n, t) -> n ^ ":" ^ t) schema - |> String.concat "," + List.map (fun (n, t) -> n ^ ":" ^ t) schema |> String.concat "," diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml index 6cb17b8..d48d852 100644 --- a/lib/scl/executor.ml +++ b/lib/scl/executor.ml @@ -6,72 +6,68 @@ type cursor_batch = { has_more : bool; } -type exec_result = - | Batch of cursor_batch - | Closed of Management.Database.t +type exec_result = Batch of cursor_batch | Closed of Management.Database.t let sessions : Session.t option ref = ref None - let set_sessions s = sessions := Some s module Make (Storage : Management.Physical.S) = struct - module DrlExec = Drl.Executor.Make(Storage) - module Alg = Algebra.Make(Storage) + module DrlExec = Drl.Executor.Make (Storage) + module Alg = Algebra.Make (Storage) type error = - | ParseError of string - | QueryError of DrlExec.error + | ParseError of string + | QueryError of DrlExec.error | CursorError of string let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | QueryError e -> DrlExec.sexp_of_error e - | CursorError s -> List [Atom "cursor-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | QueryError e -> DrlExec.sexp_of_error e + | CursorError s -> List [ Atom "cursor-error"; Atom s ] let get_sessions () = match !sessions with | Some s -> Ok s - | None -> Error (CursorError "The session registry has not been initialised; ensure `set_sessions` is called at startup.") + | None -> + Error + (CursorError + "The session registry has not been initialised; ensure \ + `set_sessions` is called at startup.") let ( let* ) = Result.bind - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (exec_result, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (exec_result, error) result = match stmt with | Ast.Begin { query; limit } -> - let* reg = get_sessions () in - let* rel = - DrlExec.execute storage db query - |> Result.map_error (fun e -> QueryError e) - in - let gen = Alg.to_generator storage rel in - let query_str = Drl.Parser.to_string query in - let cur = Session.register reg ~db ~query:query_str ~generator:gen in - let batch = Option.value ~default:default_batch limit in - let* (rows, has_more) = - Session.fetch reg ~id:cur.Session.id ~limit:batch - |> Result.map_error (fun s -> CursorError s) - in - Ok (Batch { cursor_id = cur.Session.id; rows; has_more }) - + let* reg = get_sessions () in + let* rel = + DrlExec.execute storage db query + |> Result.map_error (fun e -> QueryError e) + in + let gen = Alg.to_generator storage rel in + let query_str = Drl.Parser.to_string query in + let cur = Session.register reg ~db ~query:query_str ~generator:gen in + let batch = Option.value ~default:default_batch limit in + let* rows, has_more = + Session.fetch reg ~id:cur.Session.id ~limit:batch + |> Result.map_error (fun s -> CursorError s) + in + Ok (Batch { cursor_id = cur.Session.id; rows; has_more }) | Ast.Fetch { cursor; limit } -> - let* reg = get_sessions () in - let batch = Option.value ~default:default_batch limit in - let* (rows, has_more) = - Session.fetch reg ~id:cursor ~limit:batch - |> Result.map_error (fun s -> CursorError s) - in - Ok (Batch { cursor_id = cursor; rows; has_more }) - + let* reg = get_sessions () in + let batch = Option.value ~default:default_batch limit in + let* rows, has_more = + Session.fetch reg ~id:cursor ~limit:batch + |> Result.map_error (fun s -> CursorError s) + in + Ok (Batch { cursor_id = cursor; rows; has_more }) | Ast.Close { cursor } -> - let* reg = get_sessions () in - Session.close reg ~id:cursor; - Ok (Closed db) + let* reg = get_sessions () in + Session.close reg ~id:cursor; + Ok (Closed db) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index 7098ced..b39e720 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "scl" @@ -16,11 +16,10 @@ module Make (Storage : Management.Physical.S) = struct Exec.execute storage db ast |> Result.map (function | Executor.Batch { cursor_id; rows; has_more } -> - Sublanguage.Cursor { cursor_id; rows; has_more } - | Executor.Closed db -> - Sublanguage.Transition (db, "cursor closed")) + Sublanguage.Cursor { cursor_id; rows; has_more } + | Executor.Closed db -> Sublanguage.Transition (db, "cursor closed")) let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/session.ml b/lib/session.ml index 272a419..a58d00b 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1,8 +1,8 @@ (** Cursor registry for streaming tuple consumption. - Each cursor wraps a [Generator.t] produced by a DRL query and - tracks the current position so that successive [fetch] calls - return the next batch of rows without replaying the query. *) + Each cursor wraps a [Generator.t] produced by a DRL query and tracks the + current position so that successive [fetch] calls return the next batch of + rows without replaying the query. *) type cursor = { id : string; @@ -13,70 +13,67 @@ type cursor = { created_at : float; } -type t = { - tbl : (string, cursor) Hashtbl.t; - mutable counter : int; -} +type t = { tbl : (string, cursor) Hashtbl.t; mutable counter : int } -let create () : t = - { tbl = Hashtbl.create 16; counter = 0 } +let create () : t = { tbl = Hashtbl.create 16; counter = 0 } let register (reg : t) ~(db : Management.Database.t) ~(query : string) ~(generator : Generator.t) : cursor = let raw = string_of_int reg.counter ^ query ^ db.Management.Database.hash in let id = Conventions.Hash.hash_text raw in reg.counter <- reg.counter + 1; - let cur = { - id; - generator; - position = 0; - db_snapshot = db; - query_sexp = query; - created_at = Unix.gettimeofday (); - } in + let cur = + { + id; + generator; + position = 0; + db_snapshot = db; + query_sexp = query; + created_at = Unix.gettimeofday (); + } + in Hashtbl.replace reg.tbl id cur; cur -let fetch (reg : t) ~(id : string) ~(limit : int) - : (Tuple.materialized list * bool, string) result = +let fetch (reg : t) ~(id : string) ~(limit : int) : + (Tuple.materialized list * bool, string) result = match Hashtbl.find_opt reg.tbl id with - | None -> Error ("The cursor with identifier `" ^ id ^ "` was not found in the session registry.") + | None -> + Error + ("The cursor with identifier `" ^ id + ^ "` was not found in the session registry.") | Some cur -> - let rec go gen pos acc count = - if count >= limit then (List.rev acc, gen, pos, true) - else - match gen (Some pos) with - | Generator.Done -> (List.rev acc, gen, pos, false) - (* Generator errors are treated as exhaustion: the partial batch is + let rec go gen pos acc count = + if count >= limit then (List.rev acc, gen, pos, true) + else + match gen (Some pos) with + | Generator.Done -> (List.rev acc, gen, pos, false) + (* Generator errors are treated as exhaustion: the partial batch is returned with has_more = false and the cursor is auto-removed. The caller receives no indication that the stream terminated abnormally. When fetch gains a richer return type this arm should surface the error message instead. *) - | Generator.Error _ -> (List.rev acc, gen, pos, false) - | Generator.Value (t, next) -> - begin match t with - | Tuple.Materialized m -> - go next (pos + 1) (m :: acc) (count + 1) - | Tuple.NonMaterialized _ -> - go next (pos + 1) acc count - end - in - let (rows, gen', pos', has_more) = - go cur.generator cur.position [] 0 - in - cur.generator <- gen'; - cur.position <- pos'; - if not has_more then Hashtbl.remove reg.tbl id; - Ok (rows, has_more) + | Generator.Error _ -> (List.rev acc, gen, pos, false) + | Generator.Value (t, next) -> begin + match t with + | Tuple.Materialized m -> go next (pos + 1) (m :: acc) (count + 1) + | Tuple.NonMaterialized _ -> go next (pos + 1) acc count + end + in + let rows, gen', pos', has_more = go cur.generator cur.position [] 0 in + cur.generator <- gen'; + cur.position <- pos'; + if not has_more then Hashtbl.remove reg.tbl id; + Ok (rows, has_more) -let close (reg : t) ~(id : string) : unit = - Hashtbl.remove reg.tbl id +let close (reg : t) ~(id : string) : unit = Hashtbl.remove reg.tbl id let gc (reg : t) ~(max_age : float) : unit = let now = Unix.gettimeofday () in let to_remove = - Hashtbl.fold (fun k cur acc -> - if now -. cur.created_at >= max_age then k :: acc else acc) + Hashtbl.fold + (fun k cur acc -> + if now -. cur.created_at >= max_age then k :: acc else acc) reg.tbl [] in List.iter (Hashtbl.remove reg.tbl) to_remove diff --git a/lib/storable.ml b/lib/storable.ml index 058773c..ec0bce2 100644 --- a/lib/storable.ml +++ b/lib/storable.ml @@ -3,7 +3,8 @@ These modules define the wire format for persisting relational engine objects to storage. Each type has to_bytes/of_bytes for serialization. - The stored formats capture only the essential data needed for reconstruction: + The stored formats capture only the essential data needed for + reconstruction: - Tuple: relation name and attribute hashes - Relation: name, schema, tuple hashes, cardinality - Database: name, relation hashes, merkle tree keys, history *) @@ -12,14 +13,12 @@ module Tuple = struct type t = { relation : string; - attributes : (string * Conventions.Hash.t) list; (* attr_name -> attr_value_hash *) + attributes : (string * Conventions.Hash.t) list; + (* attr_name -> attr_value_hash *) } - let to_bytes (st : t) : bytes = - Marshal.to_bytes st [Marshal.Closures] - - let of_bytes (b : bytes) : t = - Marshal.from_bytes b 0 + let to_bytes (st : t) : bytes = Marshal.to_bytes st [ Marshal.Closures ] + let of_bytes (b : bytes) : t = Marshal.from_bytes b 0 end (** Stored relation format for serialization *) @@ -27,30 +26,26 @@ module Relation = struct type t = { name : string; schema : Schema.t; - tree_keys : Conventions.Hash.t list; (* Merkle tree contents - tuple hashes *) + tree_keys : Conventions.Hash.t list; + (* Merkle tree contents - tuple hashes *) cardinality : Conventions.Cardinality.t; } - let to_bytes (sr : t) : bytes = - Marshal.to_bytes sr [Marshal.Closures] - - let of_bytes (b : bytes) : t = - Marshal.from_bytes b 0 + let to_bytes (sr : t) : bytes = Marshal.to_bytes sr [ Marshal.Closures ] + let of_bytes (b : bytes) : t = Marshal.from_bytes b 0 end (** Stored database format for serialization *) module Database = struct type t = { name : string; - relations : (string * Conventions.Hash.t) list; (* name -> relation_hash *) - tree_keys : Conventions.Hash.t list; (* Merkle tree contents - relation hashes *) + relations : (string * Conventions.Hash.t) list; (* name -> relation_hash *) + tree_keys : Conventions.Hash.t list; + (* Merkle tree contents - relation hashes *) history : Conventions.Hash.t list; timestamp : float; } - let to_bytes (sd : t) : bytes = - Marshal.to_bytes sd [Marshal.Closures] - - let of_bytes (b : bytes) : t = - Marshal.from_bytes b 0 + let to_bytes (sd : t) : bytes = Marshal.to_bytes sd [ Marshal.Closures ] + let of_bytes (b : bytes) : t = Marshal.from_bytes b 0 end diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml index d92358e..4cfe913 100644 --- a/lib/sublanguage.ml +++ b/lib/sublanguage.ml @@ -1,24 +1,24 @@ +type cursor_result = { + cursor_id : string; + rows : Tuple.materialized list; + has_more : bool; +} (** Effect classification for sublanguage operations. Categorically: - Query: a natural transformation between instance functors (DRL). Side-effect-free; the database state is unchanged. - - Transition: a morphism in the category of database states (DDL, - DML, ICL, DCL, and future TCL). Produces a new state via - substitution (Harper, PFPL ch. 3-4). + - Transition: a morphism in the category of database states (DDL, DML, ICL, + DCL, and future TCL). Produces a new state via substitution (Harper, PFPL + ch. 3-4). Future sublanguages: - - TCL -> Transition (transaction boundaries are state morphisms - with atomicity constraints) + - TCL -> Transition (transaction boundaries are state morphisms with + atomicity constraints) - PPL -> new effect class: potentially non-terminating computation (Turing-complete; breaks the termination guarantee of DRL) - ACL -> a functor restriction: narrows the admissible natural transformations based on authorization context *) -type cursor_result = { - cursor_id : string; - rows : Tuple.materialized list; - has_more : bool; -} type result = | Query of Relation.t @@ -29,8 +29,12 @@ module type S = sig type storage type ast type error + val name : string val parse_sexp : Sexplib.Sexp.t -> (ast, error) Result.t - val execute : storage -> Management.Database.t -> ast -> (result, error) Result.t + + val execute : + storage -> Management.Database.t -> ast -> (result, error) Result.t + val sexp_of_error : error -> Sexplib.Sexp.t end diff --git a/lib/tuple.ml b/lib/tuple.ml index 11fc508..1ce73b0 100644 --- a/lib/tuple.ml +++ b/lib/tuple.ml @@ -1,8 +1,10 @@ module AttributeMap = struct - include Map.Make(String) + include Map.Make (String) + let sexp_of_t sexp_of_v m = Sexplib.Sexp.List - (List.map (fun (k, v) -> Sexplib.Sexp.List [Sexplib.Sexp.Atom k; sexp_of_v v]) + (List.map + (fun (k, v) -> Sexplib.Sexp.List [ Sexplib.Sexp.Atom k; sexp_of_v v ]) (bindings m)) end @@ -10,16 +12,17 @@ type non_materialized = { hash : Conventions.Hash.t; relation : Conventions.Name.t; attributes : Attribute.referenced AttributeMap.t; -} [@@deriving sexp_of] +} +[@@deriving sexp_of] type materialized = { - relation: Conventions.Name.t; - attributes: Attribute.materialized AttributeMap.t; -} [@@deriving sexp_of] + relation : Conventions.Name.t; + attributes : Attribute.materialized AttributeMap.t; +} +[@@deriving sexp_of] -type t = - | Materialized of materialized - | NonMaterialized of non_materialized +type t = Materialized of materialized | NonMaterialized of non_materialized [@@deriving sexp_of] -let make_materialized ~relation ~attributes = Materialized { relation; attributes } +let make_materialized ~relation ~attributes = + Materialized { relation; attributes } diff --git a/proof/drl_verified.ml b/proof/drl_verified.ml index f4c282a..137ad86 100644 --- a/proof/drl_verified.ml +++ b/proof/drl_verified.ml @@ -1,112 +1,84 @@ - (** val negb : bool -> bool **) -let negb = function -| true -> false -| false -> true +let negb = function true -> false | false -> true (** val fst : ('a1 * 'a2) -> 'a1 **) -let fst = function -| (x, _) -> x +let fst = function x, _ -> x (** val snd : ('a1 * 'a2) -> 'a2 **) -let snd = function -| (_, y) -> y +let snd = function _, y -> y (** val app : 'a1 list -> 'a1 list -> 'a1 list **) -let rec app l m = - match l with - | [] -> m - | a :: l1 -> a :: (app l1 m) +let rec app l m = match l with [] -> m | a :: l1 -> a :: app l1 m (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) -let rec map f = function -| [] -> [] -| a :: l0 -> (f a) :: (map f l0) +let rec map f = function [] -> [] | a :: l0 -> f a :: map f l0 (** val firstn : int -> 'a1 list -> 'a1 list **) let rec firstn n l = - (fun fO fS n -> if n=0 then fO () else fS (n-1)) + (fun fO fS n -> if n = 0 then fO () else fS (n - 1)) (fun _ -> []) - (fun n0 -> match l with - | [] -> [] - | a :: l0 -> a :: (firstn n0 l0)) + (fun n0 -> match l with [] -> [] | a :: l0 -> a :: firstn n0 l0) n (** val flat_map : ('a1 -> 'a2 list) -> 'a1 list -> 'a2 list **) -let rec flat_map f = function -| [] -> [] -| x :: l0 -> app (f x) (flat_map f l0) +let rec flat_map f = function [] -> [] | x :: l0 -> app (f x) (flat_map f l0) (** val existsb : ('a1 -> bool) -> 'a1 list -> bool **) -let rec existsb f = function -| [] -> false -| a :: l0 -> (||) (f a) (existsb f l0) +let rec existsb f = function [] -> false | a :: l0 -> f a || existsb f l0 (** val forallb : ('a1 -> bool) -> 'a1 list -> bool **) -let rec forallb f = function -| [] -> true -| a :: l0 -> (&&) (f a) (forallb f l0) +let rec forallb f = function [] -> true | a :: l0 -> f a && forallb f l0 (** val filter : ('a1 -> bool) -> 'a1 list -> 'a1 list **) let rec filter f = function -| [] -> [] -| x :: l0 -> if f x then x :: (filter f l0) else filter f l0 + | [] -> [] + | x :: l0 -> if f x then x :: filter f l0 else filter f l0 (** val find : ('a1 -> bool) -> 'a1 list -> 'a1 option **) let rec find f = function -| [] -> None -| x :: tl -> if f x then Some x else find f tl + | [] -> None + | x :: tl -> if f x then Some x else find f tl (** val eqb : char list -> char list -> bool **) let rec eqb s1 s2 = match s1 with - | [] -> (match s2 with - | [] -> true - | _::_ -> false) - | c1::s1' -> - (match s2 with - | [] -> false - | c2::s2' -> if (=) c1 c2 then eqb s1' s2' else false) + | [] -> ( match s2 with [] -> true | _ :: _ -> false) + | c1 :: s1' -> ( + match s2 with + | [] -> false + | c2 :: s2' -> if c1 = c2 then eqb s1' s2' else false) (** val append : char list -> char list -> char list **) -let rec append s1 s2 = - match s1 with - | [] -> s2 - | c::s1' -> c::(append s1' s2) +let rec append s1 s2 = match s1 with [] -> s2 | c :: s1' -> c :: append s1' s2 type attr_name = char list - type domain_name = char list - type schema = (attr_name * domain_name) list (** val has_attr : attr_name -> schema -> bool **) -let has_attr a s = - existsb (fun p -> eqb a (fst p)) s +let has_attr a s = existsb (fun p -> eqb a (fst p)) s (** val attr_names : schema -> attr_name list **) -let attr_names s = - map fst s +let attr_names s = map fst s (** val filter_schema : attr_name list -> schema -> schema **) -let filter_schema attrs s = - filter (fun p -> existsb (eqb (fst p)) attrs) s +let filter_schema attrs s = filter (fun p -> existsb (eqb (fst p)) attrs) s (** val merge_schema : schema -> schema -> schema **) @@ -118,48 +90,52 @@ let merge_schema s1 s2 = let remove_attrs attrs s = filter (fun p -> negb (existsb (eqb (fst p)) attrs)) s -(** val rename_in_schema : - (attr_name * attr_name) list -> schema -> schema **) +(** val rename_in_schema : (attr_name * attr_name) list -> schema -> schema **) let rename_in_schema renames s = - map (fun p -> - let a = fst p in - let d = snd p in - (match find (fun r -> eqb a (fst r)) renames with - | Some p0 -> let (_, a') = p0 in (a', d) - | None -> (a, d))) + map + (fun p -> + let a = fst p in + let d = snd p in + match find (fun r -> eqb a (fst r)) renames with + | Some p0 -> + let _, a' = p0 in + (a', d) + | None -> (a, d)) s type value (* AXIOM TO BE REALIZED *) (** val value_eqb : value -> value -> bool **) -let value_eqb = - failwith "AXIOM TO BE REALIZED (Sakura.Relation.value_eqb)" +let value_eqb = failwith "AXIOM TO BE REALIZED (Sakura.Relation.value_eqb)" type tuple = (attr_name * value) list (** val tuple_lookup : attr_name -> tuple -> value option **) let rec tuple_lookup a = function -| [] -> None -| p :: rest -> - let (a', v) = p in if eqb a a' then Some v else tuple_lookup a rest + | [] -> None + | p :: rest -> + let a', v = p in + if eqb a a' then Some v else tuple_lookup a rest (** val project_tuple : attr_name list -> tuple -> tuple **) -let project_tuple attrs t = - filter (fun p -> existsb (eqb (fst p)) attrs) t +let project_tuple attrs t = filter (fun p -> existsb (eqb (fst p)) attrs) t (** val rename_tuple : (attr_name * attr_name) list -> tuple -> tuple **) let rename_tuple renames t = - map (fun p -> - let a = fst p in - let v = snd p in - (match find (fun r -> eqb a (fst r)) renames with - | Some p0 -> let (_, a') = p0 in (a', v) - | None -> (a, v))) + map + (fun p -> + let a = fst p in + let v = snd p in + match find (fun r -> eqb a (fst r)) renames with + | Some p0 -> + let _, a' = p0 in + (a', v) + | None -> (a, v)) t (** val merge_tuples : tuple -> tuple -> tuple **) @@ -170,86 +146,85 @@ let merge_tuples t1 t2 = (** val tuples_agree_on : attr_name list -> tuple -> tuple -> bool **) let tuples_agree_on attrs t1 t2 = - forallb (fun a -> - match tuple_lookup a t1 with - | Some v1 -> - (match tuple_lookup a t2 with - | Some v2 -> value_eqb v1 v2 - | None -> false) - | None -> (match tuple_lookup a t2 with - | Some _ -> false - | None -> true)) + forallb + (fun a -> + match tuple_lookup a t1 with + | Some v1 -> ( + match tuple_lookup a t2 with + | Some v2 -> value_eqb v1 v2 + | None -> false) + | None -> ( match tuple_lookup a t2 with Some _ -> false | None -> true)) attrs -type relation = { rel_name : char list; rel_schema : schema; - rel_tuples : tuple list } +type relation = { + rel_name : char list; + rel_schema : schema; + rel_tuples : tuple list; +} type database = (char list * relation) list (** val db_lookup : char list -> database -> relation option **) let rec db_lookup name = function -| [] -> None -| p :: rest -> - let (n, r) = p in if eqb name n then Some r else db_lookup name rest + | [] -> None + | p :: rest -> + let n, r = p in + if eqb name n then Some r else db_lookup name rest -type literal = -| LitInt of int -| LitStr of char list -| LitBool of bool +type literal = LitInt of int | LitStr of char list | LitBool of bool type query = -| Base of char list -| Const of (attr_name * literal) list -| Select of query * query -| Join of attr_name list * query * query -| Cartesian of query * query -| Project of attr_name list * query -| Rename of (attr_name * attr_name) list * query -| Union of query * query -| Diff of query * query -| Take of int * query + | Base of char list + | Const of (attr_name * literal) list + | Select of query * query + | Join of attr_name list * query * query + | Cartesian of query * query + | Project of attr_name list * query + | Rename of (attr_name * attr_name) list * query + | Union of query * query + | Diff of query * query + | Take of int * query (** val predicted_schema : database -> query -> schema option **) let rec predicted_schema db = function -| Base name -> - (match db_lookup name db with - | Some r -> Some r.rel_schema - | None -> None) -| Const pairs -> - Some - (map (fun p -> ((fst p), - ('a'::('b'::('s'::('t'::('r'::('a'::('c'::('t'::[])))))))))) pairs) -| Select (_, source) -> predicted_schema db source -| Join (attrs, q1, q2) -> - (match predicted_schema db q1 with - | Some s1 -> - (match predicted_schema db q2 with - | Some s2 -> - Some - (merge_schema s1 - (remove_attrs (attr_names s1) (remove_attrs attrs s2))) + | Base name -> ( + match db_lookup name db with Some r -> Some r.rel_schema | None -> None) + | Const pairs -> + Some + (map + (fun p -> (fst p, [ 'a'; 'b'; 's'; 't'; 'r'; 'a'; 'c'; 't' ])) + pairs) + | Select (_, source) -> predicted_schema db source + | Join (attrs, q1, q2) -> ( + match predicted_schema db q1 with + | Some s1 -> ( + match predicted_schema db q2 with + | Some s2 -> + Some + (merge_schema s1 + (remove_attrs (attr_names s1) (remove_attrs attrs s2))) + | None -> None) + | None -> None) + | Cartesian (q1, q2) -> ( + match predicted_schema db q1 with + | Some s1 -> ( + match predicted_schema db q2 with + | Some s2 -> Some (merge_schema s1 s2) + | None -> None) + | None -> None) + | Project (attrs, q') -> ( + match predicted_schema db q' with + | Some s -> Some (filter_schema attrs s) | None -> None) - | None -> None) -| Cartesian (q1, q2) -> - (match predicted_schema db q1 with - | Some s1 -> - (match predicted_schema db q2 with - | Some s2 -> Some (merge_schema s1 s2) + | Rename (renames, q') -> ( + match predicted_schema db q' with + | Some s -> Some (rename_in_schema renames s) | None -> None) - | None -> None) -| Project (attrs, q') -> - (match predicted_schema db q' with - | Some s -> Some (filter_schema attrs s) - | None -> None) -| Rename (renames, q') -> - (match predicted_schema db q' with - | Some s -> Some (rename_in_schema renames s) - | None -> None) -| Union (q1, _) -> predicted_schema db q1 -| Diff (q1, _) -> predicted_schema db q1 -| Take (_, q') -> predicted_schema db q' + | Union (q1, _) -> predicted_schema db q1 + | Diff (q1, _) -> predicted_schema db q1 + | Take (_, q') -> predicted_schema db q' (** val literal_to_value : literal -> value **) @@ -259,152 +234,178 @@ let literal_to_value = (** val eval_const : (attr_name * literal) list -> relation **) let eval_const pairs = - let tuple0 = map (fun p -> ((fst p), (literal_to_value (snd p)))) pairs in + let tuple0 = map (fun p -> (fst p, literal_to_value (snd p))) pairs in let sch = - map (fun p -> ((fst p), - ('a'::('b'::('s'::('t'::('r'::('a'::('c'::('t'::[])))))))))) pairs + map (fun p -> (fst p, [ 'a'; 'b'; 's'; 't'; 'r'; 'a'; 'c'; 't' ])) pairs in - { rel_name = ('c'::('o'::('n'::('s'::('t'::[]))))); rel_schema = sch; - rel_tuples = (tuple0 :: []) } + { + rel_name = [ 'c'; 'o'; 'n'; 's'; 't' ]; + rel_schema = sch; + rel_tuples = tuple0 :: []; + } (** val semijoin : relation -> relation -> relation **) let semijoin filter_rel source = let common = - filter (fun a -> has_attr a filter_rel.rel_schema) + filter + (fun a -> has_attr a filter_rel.rel_schema) (attr_names source.rel_schema) in - let matches = fun t -> + let matches = + fun t -> existsb (fun ft -> tuples_agree_on common t ft) filter_rel.rel_tuples in - { rel_name = source.rel_name; rel_schema = source.rel_schema; rel_tuples = - (filter matches source.rel_tuples) } + { + rel_name = source.rel_name; + rel_schema = source.rel_schema; + rel_tuples = filter matches source.rel_tuples; + } (** val equijoin : attr_name list -> relation -> relation -> relation **) let equijoin attrs left right = let joined = - flat_map (fun lt -> - flat_map (fun rt -> - if tuples_agree_on attrs lt rt then (merge_tuples lt rt) :: [] else []) - right.rel_tuples) + flat_map + (fun lt -> + flat_map + (fun rt -> + if tuples_agree_on attrs lt rt then merge_tuples lt rt :: [] else []) + right.rel_tuples) left.rel_tuples in let new_schema = merge_schema left.rel_schema - (remove_attrs (attr_names left.rel_schema) - (remove_attrs attrs right.rel_schema)) + (remove_attrs + (attr_names left.rel_schema) + (remove_attrs attrs right.rel_schema)) in - { rel_name = - (append ('j'::('o'::('i'::('n'::('_'::[]))))) - (append left.rel_name (append ('_'::[]) right.rel_name))); - rel_schema = new_schema; rel_tuples = joined } + { + rel_name = + append + [ 'j'; 'o'; 'i'; 'n'; '_' ] + (append left.rel_name (append ('_' :: []) right.rel_name)); + rel_schema = new_schema; + rel_tuples = joined; + } (** val cartesian : relation -> relation -> relation **) let cartesian left right = let joined = - flat_map (fun lt -> map (fun rt -> merge_tuples lt rt) right.rel_tuples) + flat_map + (fun lt -> map (fun rt -> merge_tuples lt rt) right.rel_tuples) left.rel_tuples in - { rel_name = - (append ('c'::('a'::('r'::('t'::('_'::[]))))) - (append left.rel_name (append ('_'::[]) right.rel_name))); - rel_schema = (merge_schema left.rel_schema right.rel_schema); rel_tuples = - joined } + { + rel_name = + append + [ 'c'; 'a'; 'r'; 't'; '_' ] + (append left.rel_name (append ('_' :: []) right.rel_name)); + rel_schema = merge_schema left.rel_schema right.rel_schema; + rel_tuples = joined; + } (** val project : attr_name list -> relation -> relation **) let project attrs r = - { rel_name = (append ('p'::('r'::('o'::('j'::('_'::[]))))) r.rel_name); - rel_schema = (filter_schema attrs r.rel_schema); rel_tuples = - (map (project_tuple attrs) r.rel_tuples) } + { + rel_name = append [ 'p'; 'r'; 'o'; 'j'; '_' ] r.rel_name; + rel_schema = filter_schema attrs r.rel_schema; + rel_tuples = map (project_tuple attrs) r.rel_tuples; + } (** val rename : (attr_name * attr_name) list -> relation -> relation **) let rename renames r = - { rel_name = - (append ('r'::('e'::('n'::('a'::('m'::('e'::('_'::[]))))))) r.rel_name); - rel_schema = (rename_in_schema renames r.rel_schema); rel_tuples = - (map (rename_tuple renames) r.rel_tuples) } + { + rel_name = append [ 'r'; 'e'; 'n'; 'a'; 'm'; 'e'; '_' ] r.rel_name; + rel_schema = rename_in_schema renames r.rel_schema; + rel_tuples = map (rename_tuple renames) r.rel_tuples; + } (** val rel_union : relation -> relation -> relation **) let rel_union r1 r2 = - { rel_name = - (append ('u'::('n'::('i'::('o'::('n'::('_'::[])))))) - (append r1.rel_name (append ('_'::[]) r2.rel_name))); - rel_schema = r1.rel_schema; rel_tuples = - (app r1.rel_tuples r2.rel_tuples) } + { + rel_name = + append + [ 'u'; 'n'; 'i'; 'o'; 'n'; '_' ] + (append r1.rel_name (append ('_' :: []) r2.rel_name)); + rel_schema = r1.rel_schema; + rel_tuples = app r1.rel_tuples r2.rel_tuples; + } (** val rel_diff : relation -> relation -> relation **) let rel_diff r1 r2 = - let in_r2 = fun t -> - existsb (fun t2 -> tuples_agree_on (attr_names r1.rel_schema) t t2) + let in_r2 = + fun t -> + existsb + (fun t2 -> tuples_agree_on (attr_names r1.rel_schema) t t2) r2.rel_tuples in - { rel_name = - (append ('d'::('i'::('f'::('f'::('_'::[]))))) - (append r1.rel_name (append ('_'::[]) r2.rel_name))); - rel_schema = r1.rel_schema; rel_tuples = - (filter (fun t -> negb (in_r2 t)) r1.rel_tuples) } + { + rel_name = + append + [ 'd'; 'i'; 'f'; 'f'; '_' ] + (append r1.rel_name (append ('_' :: []) r2.rel_name)); + rel_schema = r1.rel_schema; + rel_tuples = filter (fun t -> negb (in_r2 t)) r1.rel_tuples; + } (** val take : int -> relation -> relation **) let take n r = - { rel_name = (append ('t'::('a'::('k'::('e'::('_'::[]))))) r.rel_name); - rel_schema = r.rel_schema; rel_tuples = (firstn n r.rel_tuples) } + { + rel_name = append [ 't'; 'a'; 'k'; 'e'; '_' ] r.rel_name; + rel_schema = r.rel_schema; + rel_tuples = firstn n r.rel_tuples; + } (** val eval : database -> query -> relation option **) let rec eval db = function -| Base name -> db_lookup name db -| Const pairs -> Some (eval_const pairs) -| Select (filter_q, source_q) -> - (match eval db filter_q with - | Some filter_rel -> - (match eval db source_q with - | Some source_rel -> Some (semijoin filter_rel source_rel) + | Base name -> db_lookup name db + | Const pairs -> Some (eval_const pairs) + | Select (filter_q, source_q) -> ( + match eval db filter_q with + | Some filter_rel -> ( + match eval db source_q with + | Some source_rel -> Some (semijoin filter_rel source_rel) + | None -> None) | None -> None) - | None -> None) -| Join (attrs, q1, q2) -> - (match eval db q1 with - | Some r1 -> - (match eval db q2 with - | Some r2 -> Some (equijoin attrs r1 r2) + | Join (attrs, q1, q2) -> ( + match eval db q1 with + | Some r1 -> ( + match eval db q2 with + | Some r2 -> Some (equijoin attrs r1 r2) + | None -> None) | None -> None) - | None -> None) -| Cartesian (q1, q2) -> - (match eval db q1 with - | Some r1 -> - (match eval db q2 with - | Some r2 -> Some (cartesian r1 r2) + | Cartesian (q1, q2) -> ( + match eval db q1 with + | Some r1 -> ( + match eval db q2 with + | Some r2 -> Some (cartesian r1 r2) + | None -> None) | None -> None) - | None -> None) -| Project (attrs, q') -> - (match eval db q' with - | Some r -> Some (project attrs r) - | None -> None) -| Rename (renames, q') -> - (match eval db q' with - | Some r -> Some (rename renames r) - | None -> None) -| Union (q1, q2) -> - (match eval db q1 with - | Some r1 -> - (match eval db q2 with - | Some r2 -> Some (rel_union r1 r2) + | Project (attrs, q') -> ( + match eval db q' with Some r -> Some (project attrs r) | None -> None) + | Rename (renames, q') -> ( + match eval db q' with Some r -> Some (rename renames r) | None -> None) + | Union (q1, q2) -> ( + match eval db q1 with + | Some r1 -> ( + match eval db q2 with + | Some r2 -> Some (rel_union r1 r2) + | None -> None) | None -> None) - | None -> None) -| Diff (q1, q2) -> - (match eval db q1 with - | Some r1 -> - (match eval db q2 with - | Some r2 -> Some (rel_diff r1 r2) + | Diff (q1, q2) -> ( + match eval db q1 with + | Some r1 -> ( + match eval db q2 with + | Some r2 -> Some (rel_diff r1 r2) + | None -> None) | None -> None) - | None -> None) -| Take (n, q') -> - (match eval db q' with - | Some r -> Some (take n r) - | None -> None) + | Take (n, q') -> ( + match eval db q' with Some r -> Some (take n r) | None -> None) diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml index 619bc27..1d8f1ca 100644 --- a/test/test_relational_engine.ml +++ b/test/test_relational_engine.ml @@ -58,84 +58,78 @@ let%test_unit "merkle: root hash changes on insert" = assert (root1 <> root2) let%test_unit "merkle: same elements produce same root hash" = - let tree1 = Merkle.empty - |> Merkle.insert "a" - |> Merkle.insert "b" in - let tree2 = Merkle.empty - |> Merkle.insert "b" - |> Merkle.insert "a" in + let tree1 = Merkle.empty |> Merkle.insert "a" |> Merkle.insert "b" in + let tree2 = Merkle.empty |> Merkle.insert "b" |> Merkle.insert "a" in assert (Merkle.root_hash tree1 = Merkle.root_hash tree2) let%test_unit "storage: create and close" = match Management.Physical.Memory.create () with | Error _ -> assert false - | Ok storage -> - Management.Physical.Memory.close storage + | Ok storage -> Management.Physical.Memory.close storage let%test_unit "storage: store and load attribute" = match Management.Physical.Memory.create () with | Error _ -> assert false | Ok storage -> - let value = Obj.magic 42 in - (match Management.Physical.Memory.store_attribute storage value with - | Error _ -> assert false - | Ok hash -> - (match Management.Physical.Memory.load_attribute storage hash with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded) -> - assert ((Obj.magic loaded : int) = 42))); - Management.Physical.Memory.close storage + let value = Obj.magic 42 in + (match Management.Physical.Memory.store_attribute storage value with + | Error _ -> assert false + | Ok hash -> ( + match Management.Physical.Memory.load_attribute storage hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded) -> assert ((Obj.magic loaded : int) = 42))); + Management.Physical.Memory.close storage let%test_unit "storage: store and load raw bytes" = match Management.Physical.Memory.create () with | Error _ -> assert false | Ok storage -> - let hash = "test_hash" in - let data = Bytes.of_string "hello world" in - (match Management.Physical.Memory.store_raw storage hash data with - | Error _ -> assert false - | Ok () -> - (match Management.Physical.Memory.load_raw storage hash with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded) -> - assert (Bytes.equal loaded data))); - Management.Physical.Memory.close storage + let hash = "test_hash" in + let data = Bytes.of_string "hello world" in + (match Management.Physical.Memory.store_raw storage hash data with + | Error _ -> assert false + | Ok () -> ( + match Management.Physical.Memory.load_raw storage hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded) -> assert (Bytes.equal loaded data))); + Management.Physical.Memory.close storage let%test_unit "storage: exists check" = match Management.Physical.Memory.create () with | Error _ -> assert false | Ok storage -> - let hash = "exists_test" in - let data = Bytes.of_string "data" in - (match Management.Physical.Memory.exists storage hash with - | Error _ -> assert false - | Ok exists -> assert (not exists)); - (match Management.Physical.Memory.store_raw storage hash data with - | Error _ -> assert false - | Ok () -> - (match Management.Physical.Memory.exists storage hash with - | Error _ -> assert false - | Ok exists -> assert exists)); - Management.Physical.Memory.close storage + let hash = "exists_test" in + let data = Bytes.of_string "data" in + (match Management.Physical.Memory.exists storage hash with + | Error _ -> assert false + | Ok exists -> assert (not exists)); + (match Management.Physical.Memory.store_raw storage hash data with + | Error _ -> assert false + | Ok () -> ( + match Management.Physical.Memory.exists storage hash with + | Error _ -> assert false + | Ok exists -> assert exists)); + Management.Physical.Memory.close storage let%test_unit "storage: transaction commit" = match Management.Physical.Memory.create () with | Error _ -> assert false | Ok storage -> - let result = Management.Physical.Memory.with_transaction storage (fun () -> - let hash = "tx_test" in - let data = Bytes.of_string "tx_data" in - Management.Physical.Memory.store_raw storage hash data - ) in - (match result with - | Error _ -> assert false - | Ok () -> - (match Management.Physical.Memory.exists storage "tx_test" with - | Error _ -> assert false - | Ok exists -> assert exists)); - Management.Physical.Memory.close storage + let result = + Management.Physical.Memory.with_transaction storage (fun () -> + let hash = "tx_test" in + let data = Bytes.of_string "tx_data" in + Management.Physical.Memory.store_raw storage hash data) + in + (match result with + | Error _ -> assert false + | Ok () -> ( + match Management.Physical.Memory.exists storage "tx_test" with + | Error _ -> assert false + | Ok exists -> assert exists)); + Management.Physical.Memory.close storage let%test_unit "database: create empty" = let db = Management.Database.empty ~name:"test_db" in @@ -147,17 +141,13 @@ let%test_unit "database: create empty" = let%test_unit "database: add relation" = let db = Management.Database.empty ~name:"test_db" in (* Create a minimal relation for testing *) - let relation = Relation.make - ~hash:(Some "rel_hash_1") - ~name:"users" - ~schema:Schema.empty - ~tree:(Some Merkle.empty) - ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite 0) - ~generator:None - ~membership_criteria:(fun _ -> true) - ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") + let relation = + Relation.make ~hash:(Some "rel_hash_1") ~name:"users" ~schema:Schema.empty + ~tree:(Some Merkle.empty) ~constraints:None + ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None + ~membership_criteria:(fun _ -> true) + ~provenance:Relation.Provenance.Undefined + ~lineage:(Relation.Lineage.Base "users") in let db = Management.Database.add_relation db ~relation in assert (Management.Database.has_relation db "users"); @@ -166,17 +156,13 @@ let%test_unit "database: add relation" = let%test_unit "database: remove relation" = let db = Management.Database.empty ~name:"test_db" in - let relation = Relation.make - ~hash:(Some "hash1") - ~name:"users" - ~schema:Schema.empty - ~tree:(Some Merkle.empty) - ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite 0) - ~generator:None - ~membership_criteria:(fun _ -> true) - ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") + let relation = + Relation.make ~hash:(Some "hash1") ~name:"users" ~schema:Schema.empty + ~tree:(Some Merkle.empty) ~constraints:None + ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None + ~membership_criteria:(fun _ -> true) + ~provenance:Relation.Provenance.Undefined + ~lineage:(Relation.Lineage.Base "users") in let db = Management.Database.add_relation db ~relation in assert (Management.Database.has_relation db "users"); @@ -185,17 +171,13 @@ let%test_unit "database: remove relation" = let%test_unit "database: update relation" = let db = Management.Database.empty ~name:"test_db" in - let relation = Relation.make - ~hash:(Some "hash1") - ~name:"users" - ~schema:Schema.empty - ~tree:(Some Merkle.empty) - ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite 0) - ~generator:None - ~membership_criteria:(fun _ -> true) - ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") + let relation = + Relation.make ~hash:(Some "hash1") ~name:"users" ~schema:Schema.empty + ~tree:(Some Merkle.empty) ~constraints:None + ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None + ~membership_criteria:(fun _ -> true) + ~provenance:Relation.Provenance.Undefined + ~lineage:(Relation.Lineage.Base "users") in let db = Management.Database.add_relation db ~relation in let old_db_hash = db.hash in @@ -207,29 +189,21 @@ let%test_unit "database: update relation" = let%test_unit "database: get relation names" = let db = Management.Database.empty ~name:"test_db" in - let rel1 = Relation.make - ~hash:(Some "h1") - ~name:"users" - ~schema:Schema.empty - ~tree:(Some Merkle.empty) - ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite 0) - ~generator:None - ~membership_criteria:(fun _ -> true) - ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") - in - let rel2 = Relation.make - ~hash:(Some "h2") - ~name:"orders" - ~schema:Schema.empty - ~tree:(Some Merkle.empty) - ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite 0) - ~generator:None - ~membership_criteria:(fun _ -> true) - ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "orders") + let rel1 = + Relation.make ~hash:(Some "h1") ~name:"users" ~schema:Schema.empty + ~tree:(Some Merkle.empty) ~constraints:None + ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None + ~membership_criteria:(fun _ -> true) + ~provenance:Relation.Provenance.Undefined + ~lineage:(Relation.Lineage.Base "users") + in + let rel2 = + Relation.make ~hash:(Some "h2") ~name:"orders" ~schema:Schema.empty + ~tree:(Some Merkle.empty) ~constraints:None + ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None + ~membership_criteria:(fun _ -> true) + ~provenance:Relation.Provenance.Undefined + ~lineage:(Relation.Lineage.Base "orders") in let db = Management.Database.add_relation db ~relation:rel1 in let db = Management.Database.add_relation db ~relation:rel2 in @@ -243,780 +217,1039 @@ let with_storage f = match Management.Physical.Memory.create () with | Error _ -> assert false | Ok storage -> - let result = f storage in - Management.Physical.Memory.close storage; - result + let result = f storage in + Management.Physical.Memory.close storage; + result let%test_unit "manipulation: create database" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"my_db" with - | Error _ -> assert false - | Ok db -> assert (db.name = "my_db")) + match Manipulation.Memory.create_database storage ~name:"my_db" with + | Error _ -> assert false + | Ok db -> assert (db.name = "my_db")) let%test_unit "manipulation: create relation" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "name" "string" - |> Schema.add "age" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - assert (relation.name = "users"); - assert (relation.schema = schema); - assert (Management.Database.has_relation db "users")) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = + Schema.empty |> Schema.add "name" "string" |> Schema.add "age" "integer" + in + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, relation) -> + assert (relation.name = "users"); + assert (relation.schema = schema); + assert (Management.Database.has_relation db "users")) let%test_unit "manipulation: create relation already exists" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false - | Ok (db, _) -> - match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error (Manipulation.RelationAlreadyExists _) -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, _) -> ( + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error (Manipulation.RelationAlreadyExists _) -> () + | _ -> assert false)) let%test_unit "manipulation: retract relation" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false - | Ok (db, _) -> - assert (Management.Database.has_relation db "users"); - match Manipulation.Memory.retract_relation storage db ~name:"users" with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with | Error _ -> assert false - | Ok db -> - assert (not (Management.Database.has_relation db "users"))) + | Ok (db, _) -> ( + assert (Management.Database.has_relation db "users"); + match + Manipulation.Memory.retract_relation storage db ~name:"users" + with + | Error _ -> assert false + | Ok db -> assert (not (Management.Database.has_relation db "users")))) let%test_unit "manipulation: create tuple with storage" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "name" "string" in - match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "name" { Attribute.value = Obj.magic "Alice" } in - let tuple : Tuple.materialized = { relation = "users"; attributes = attrs } in - match Manipulation.Memory.create_tuple storage db relation tuple with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "name" "string" in + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with | Error _ -> assert false - | Ok (_db, new_relation, _hash) -> - assert (Manipulation.Memory.tuple_count new_relation = 1)) + | Ok (db, relation) -> ( + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "name" + { Attribute.value = Obj.magic "Alice" } + in + let tuple : Tuple.materialized = + { relation = "users"; attributes = attrs } + in + match Manipulation.Memory.create_tuple storage db relation tuple with + | Error _ -> assert false + | Ok (_db, new_relation, _hash) -> + assert (Manipulation.Memory.tuple_count new_relation = 1))) let%test_unit "manipulation: create and load tuple" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "value" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"numbers" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "value" { Attribute.value = Obj.magic 42 } in - let tuple : Tuple.materialized = { relation = "numbers"; attributes = attrs } in - match Manipulation.Memory.create_tuple storage db relation tuple with - | Error _ -> assert false - | Ok (_db, _relation, tuple_hash) -> - (* Now load the tuple back from storage *) - match Manipulation.Memory.load_tuple storage tuple_hash with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded_tuple) -> - assert (loaded_tuple.relation = "numbers"); - let loaded_value = Tuple.AttributeMap.find "value" loaded_tuple.attributes in - assert ((Obj.magic loaded_value.Attribute.value : int) = 42)) + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "value" "integer" in + match + Manipulation.Memory.create_relation storage db ~name:"numbers" ~schema + with + | Error _ -> assert false + | Ok (db, relation) -> ( + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "value" { Attribute.value = Obj.magic 42 } + in + let tuple : Tuple.materialized = + { relation = "numbers"; attributes = attrs } + in + match Manipulation.Memory.create_tuple storage db relation tuple with + | Error _ -> assert false + | Ok (_db, _relation, tuple_hash) -> ( + (* Now load the tuple back from storage *) + match Manipulation.Memory.load_tuple storage tuple_hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded_tuple) -> + assert (loaded_tuple.relation = "numbers"); + let loaded_value = + Tuple.AttributeMap.find "value" loaded_tuple.attributes + in + assert ((Obj.magic loaded_value.Attribute.value : int) = 42)))) let%test_unit "manipulation: create multiple tuples with storage" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "id" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"items" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let make_tuple id = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "id" { Attribute.value = Obj.magic id } in - ({ Tuple.relation = "items"; attributes = attrs } : Tuple.materialized) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db in - let tuples = [make_tuple 1; make_tuple 2; make_tuple 3] in - match Manipulation.Memory.create_tuples storage db relation tuples with + let schema = Schema.empty |> Schema.add "id" "integer" in + match + Manipulation.Memory.create_relation storage db ~name:"items" ~schema + with | Error _ -> assert false - | Ok (_db, new_relation, hashes) -> - assert (Manipulation.Memory.tuple_count new_relation = 3); - assert (List.length hashes = 3)) + | Ok (db, relation) -> ( + let make_tuple id = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "id" { Attribute.value = Obj.magic id } + in + ({ Tuple.relation = "items"; attributes = attrs } + : Tuple.materialized) + in + let tuples = [ make_tuple 1; make_tuple 2; make_tuple 3 ] in + match + Manipulation.Memory.create_tuples storage db relation tuples + with + | Error _ -> assert false + | Ok (_db, new_relation, hashes) -> + assert (Manipulation.Memory.tuple_count new_relation = 3); + assert (List.length hashes = 3))) let%test_unit "manipulation: load multiple tuples" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "n" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"test" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let make_tuple n = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "n" { Attribute.value = Obj.magic n } in - ({ Tuple.relation = "test"; attributes = attrs } : Tuple.materialized) - in - match Manipulation.Memory.create_tuples storage db relation [make_tuple 10; make_tuple 20] with - | Error _ -> assert false - | Ok (_db, _relation, hashes) -> - match Manipulation.Memory.load_tuples storage hashes with - | Error _ -> assert false - | Ok loaded -> - assert (List.length loaded = 2); - let values = List.map (fun t -> - let attr = Tuple.AttributeMap.find "n" t.Tuple.attributes in - (Obj.magic attr.Attribute.value : int) - ) loaded in - assert (List.mem 10 values); - assert (List.mem 20 values)) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "n" "integer" in + match + Manipulation.Memory.create_relation storage db ~name:"test" ~schema + with + | Error _ -> assert false + | Ok (db, relation) -> ( + let make_tuple n = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "n" { Attribute.value = Obj.magic n } + in + ({ Tuple.relation = "test"; attributes = attrs } + : Tuple.materialized) + in + match + Manipulation.Memory.create_tuples storage db relation + [ make_tuple 10; make_tuple 20 ] + with + | Error _ -> assert false + | Ok (_db, _relation, hashes) -> ( + match Manipulation.Memory.load_tuples storage hashes with + | Error _ -> assert false + | Ok loaded -> + assert (List.length loaded = 2); + let values = + List.map + (fun t -> + let attr = + Tuple.AttributeMap.find "n" t.Tuple.attributes + in + (Obj.magic attr.Attribute.value : int)) + loaded + in + assert (List.mem 10 values); + assert (List.mem 20 values)))) let%test_unit "manipulation: retract tuple" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "value" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"numbers" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "value" { Attribute.value = Obj.magic 42 } in - let tuple : Tuple.materialized = { relation = "numbers"; attributes = attrs } in - match Manipulation.Memory.create_tuple storage db relation tuple with - | Error _ -> assert false - | Ok (db, relation, tuple_hash) -> - assert (Manipulation.Memory.tuple_count relation = 1); - match Manipulation.Memory.retract_tuple storage db relation ~tuple_hash with - | Error _ -> assert false - | Ok (_db, relation) -> - assert (Manipulation.Memory.tuple_count relation = 0); - (* Tuple data still exists in storage (append-only) *) - match Manipulation.Memory.load_tuple storage tuple_hash with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "value" "integer" in + match + Manipulation.Memory.create_relation storage db ~name:"numbers" ~schema + with + | Error _ -> assert false + | Ok (db, relation) -> ( + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "value" { Attribute.value = Obj.magic 42 } + in + let tuple : Tuple.materialized = + { relation = "numbers"; attributes = attrs } + in + match Manipulation.Memory.create_tuple storage db relation tuple with | Error _ -> assert false - | Ok None -> assert false - | Ok (Some _) -> () (* Data is still there *)) + | Ok (db, relation, tuple_hash) -> ( + assert (Manipulation.Memory.tuple_count relation = 1); + match + Manipulation.Memory.retract_tuple storage db relation + ~tuple_hash + with + | Error _ -> assert false + | Ok (_db, relation) -> ( + assert (Manipulation.Memory.tuple_count relation = 0); + (* Tuple data still exists in storage (append-only) *) + match Manipulation.Memory.load_tuple storage tuple_hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some _) -> () (* Data is still there *))))) let%test_unit "manipulation: tuple hashes" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - match Manipulation.Memory.create_relation storage db ~name:"test" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let make_tuple n = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "n" { Attribute.value = Obj.magic n } in - ({ Tuple.relation = "test"; attributes = attrs } : Tuple.materialized) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db in - match Manipulation.Memory.create_tuples storage db relation [make_tuple 1; make_tuple 2] with + let schema = Schema.empty in + match + Manipulation.Memory.create_relation storage db ~name:"test" ~schema + with | Error _ -> assert false - | Ok (_db, relation, _) -> - let hashes = Manipulation.Memory.tuple_hashes relation in - assert (List.length hashes = 2)) + | Ok (db, relation) -> ( + let make_tuple n = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "n" { Attribute.value = Obj.magic n } + in + ({ Tuple.relation = "test"; attributes = attrs } + : Tuple.materialized) + in + match + Manipulation.Memory.create_tuples storage db relation + [ make_tuple 1; make_tuple 2 ] + with + | Error _ -> assert false + | Ok (_db, relation, _) -> + let hashes = Manipulation.Memory.tuple_hashes relation in + assert (List.length hashes = 2))) let%test_unit "manipulation: clear relation" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - match Manipulation.Memory.create_relation storage db ~name:"test" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let make_tuple n = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "n" { Attribute.value = Obj.magic n } in - ({ Tuple.relation = "test"; attributes = attrs } : Tuple.materialized) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db in - match Manipulation.Memory.create_tuples storage db relation [make_tuple 1; make_tuple 2; make_tuple 3] with + let schema = Schema.empty in + match + Manipulation.Memory.create_relation storage db ~name:"test" ~schema + with | Error _ -> assert false - | Ok (db, relation, _) -> - assert (Manipulation.Memory.tuple_count relation = 3); - match Manipulation.Memory.clear_relation storage db relation with - | Error _ -> assert false - | Ok (_db, relation) -> - assert (Manipulation.Memory.tuple_count relation = 0)) + | Ok (db, relation) -> ( + let make_tuple n = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "n" { Attribute.value = Obj.magic n } + in + ({ Tuple.relation = "test"; attributes = attrs } + : Tuple.materialized) + in + match + Manipulation.Memory.create_tuples storage db relation + [ make_tuple 1; make_tuple 2; make_tuple 3 ] + with + | Error _ -> assert false + | Ok (db, relation, _) -> ( + assert (Manipulation.Memory.tuple_count relation = 3); + match Manipulation.Memory.clear_relation storage db relation with + | Error _ -> assert false + | Ok (_db, relation) -> + assert (Manipulation.Memory.tuple_count relation = 0)))) let%test_unit "manipulation: duplicate tuple rejected" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "x" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"test" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 1 } in - let tuple : Tuple.materialized = { relation = "test"; attributes = attrs } in - match Manipulation.Memory.create_tuple storage db relation tuple with - | Error _ -> assert false - | Ok (db, relation, _) -> - (* Try to insert the same tuple again *) - match Manipulation.Memory.create_tuple storage db relation tuple with - | Error (Manipulation.DuplicateTuple _) -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "x" "integer" in + match + Manipulation.Memory.create_relation storage db ~name:"test" ~schema + with + | Error _ -> assert false + | Ok (db, relation) -> ( + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 1 } + in + let tuple : Tuple.materialized = + { relation = "test"; attributes = attrs } + in + match Manipulation.Memory.create_tuple storage db relation tuple with + | Error _ -> assert false + | Ok (db, relation, _) -> ( + (* Try to insert the same tuple again *) + match + Manipulation.Memory.create_tuple storage db relation tuple + with + | Error (Manipulation.DuplicateTuple _) -> () + | _ -> assert false))) let%test_unit "manipulation: tuple_exists check" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - match Manipulation.Memory.create_relation storage db ~name:"test" ~schema with - | Error _ -> assert false - | Ok (db, relation) -> - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "v" { Attribute.value = Obj.magic 99 } in - let tuple : Tuple.materialized = { relation = "test"; attributes = attrs } in - let tuple_hash = Manipulation.hash_tuple tuple in - assert (not (Manipulation.Memory.tuple_exists relation tuple_hash)); - match Manipulation.Memory.create_tuple storage db relation tuple with - | Error _ -> assert false - | Ok (_db, relation, hash) -> - assert (hash = tuple_hash); - assert (Manipulation.Memory.tuple_exists relation tuple_hash)) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in + match + Manipulation.Memory.create_relation storage db ~name:"test" ~schema + with + | Error _ -> assert false + | Ok (db, relation) -> ( + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "v" { Attribute.value = Obj.magic 99 } + in + let tuple : Tuple.materialized = + { relation = "test"; attributes = attrs } + in + let tuple_hash = Manipulation.hash_tuple tuple in + assert (not (Manipulation.Memory.tuple_exists relation tuple_hash)); + match Manipulation.Memory.create_tuple storage db relation tuple with + | Error _ -> assert false + | Ok (_db, relation, hash) -> + assert (hash = tuple_hash); + assert (Manipulation.Memory.tuple_exists relation tuple_hash))) let%test_unit "manipulation: hash_tuple deterministic" = - let attrs = Tuple.AttributeMap.empty + let attrs = + Tuple.AttributeMap.empty |> Tuple.AttributeMap.add "a" { Attribute.value = Obj.magic 1 } - |> Tuple.AttributeMap.add "b" { Attribute.value = Obj.magic 2 } in + |> Tuple.AttributeMap.add "b" { Attribute.value = Obj.magic 2 } + in let tuple : Tuple.materialized = { relation = "test"; attributes = attrs } in let hash1 = Manipulation.hash_tuple tuple in let hash2 = Manipulation.hash_tuple tuple in assert (hash1 = hash2) let%test_unit "manipulation: different tuples different hashes" = - let tuple1 : Tuple.materialized = { - relation = "test"; - attributes = Tuple.AttributeMap.singleton "x" { Attribute.value = Obj.magic 1 } - } in - let tuple2 : Tuple.materialized = { - relation = "test"; - attributes = Tuple.AttributeMap.singleton "x" { Attribute.value = Obj.magic 2 } - } in + let tuple1 : Tuple.materialized = + { + relation = "test"; + attributes = + Tuple.AttributeMap.singleton "x" { Attribute.value = Obj.magic 1 }; + } + in + let tuple2 : Tuple.materialized = + { + relation = "test"; + attributes = + Tuple.AttributeMap.singleton "x" { Attribute.value = Obj.magic 2 }; + } + in let hash1 = Manipulation.hash_tuple tuple1 in let hash2 = Manipulation.hash_tuple tuple2 in assert (hash1 <> hash2) let%test_unit "manipulation: get_relation from database" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "id" "integer" in - match Manipulation.Memory.create_relation storage db ~name:"items" ~schema with - | Error _ -> assert false - | Ok (db, _relation) -> - (* Now get the relation from the database *) - match Manipulation.Memory.get_relation db ~name:"items" with - | None -> assert false - | Some rel -> - assert (rel.name = "items"); - assert (rel.schema = schema)) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "id" "integer" in + match + Manipulation.Memory.create_relation storage db ~name:"items" ~schema + with + | Error _ -> assert false + | Ok (db, _relation) -> ( + (* Now get the relation from the database *) + match Manipulation.Memory.get_relation db ~name:"items" with + | None -> assert false + | Some rel -> + assert (rel.name = "items"); + assert (rel.schema = schema))) let%test_unit "schema: persisted and loaded correctly" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty - |> Schema.add "id" "integer" - |> Schema.add "name" "string" - |> Schema.add "email" "string" in - match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false - | Ok (db, _relation) -> - (* Get the relation hash *) - let rel_hash = Option.get (Management.Database.get_relation_hash db "users") in - (* Load the relation from storage *) - match Manipulation.Memory.load_relation storage rel_hash with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = + Schema.empty |> Schema.add "id" "integer" |> Schema.add "name" "string" + |> Schema.add "email" "string" + in + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded_rel) -> - (* Verify schema was persisted and loaded correctly *) - assert (loaded_rel.schema = schema); - assert (List.mem ("id", "integer") loaded_rel.schema); - assert (List.mem ("name", "string") loaded_rel.schema); - assert (List.mem ("email", "string") loaded_rel.schema)) + | Ok (db, _relation) -> ( + (* Get the relation hash *) + let rel_hash = + Option.get (Management.Database.get_relation_hash db "users") + in + (* Load the relation from storage *) + match Manipulation.Memory.load_relation storage rel_hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded_rel) -> + (* Verify schema was persisted and loaded correctly *) + assert (loaded_rel.schema = schema); + assert (List.mem ("id", "integer") loaded_rel.schema); + assert (List.mem ("name", "string") loaded_rel.schema); + assert (List.mem ("email", "string") loaded_rel.schema))) let%test_unit "catalog: create_database seeds 6 catalog relations" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let catalog_names = Prelude.Catalog.catalog_relation_names in - List.iter (fun name -> - assert (Management.Database.has_relation db name) - ) catalog_names) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let catalog_names = Prelude.Catalog.catalog_relation_names in + List.iter + (fun name -> assert (Management.Database.has_relation db name)) + catalog_names) let%test_unit "catalog: sakura:relation contains all 6 catalog names" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let rel = match Manipulation.Memory.get_relation db ~name:"sakura:relation" with - | None -> assert false - | Some r -> r - in - assert (Manipulation.Memory.tuple_count rel = 6)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let rel = + match + Manipulation.Memory.get_relation db ~name:"sakura:relation" + with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count rel = 6)) let%test_unit "catalog: sakura:on contains insert, update, delete" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let on_rel = match Manipulation.Memory.get_relation db ~name:"sakura:on" with - | None -> assert false - | Some r -> r - in - assert (Manipulation.Memory.tuple_count on_rel = 3)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let on_rel = + match Manipulation.Memory.get_relation db ~name:"sakura:on" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count on_rel = 3)) let%test_unit "catalog: sakura:timing contains immediate, deferred" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let timing_rel = match Manipulation.Memory.get_relation db ~name:"sakura:timing" with - | None -> assert false - | Some r -> r - in - assert (Manipulation.Memory.tuple_count timing_rel = 2)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let timing_rel = + match Manipulation.Memory.get_relation db ~name:"sakura:timing" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count timing_rel = 2)) let%test_unit "catalog: sakura:domain seeded with 4 prelude domains" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let dom_rel = match Manipulation.Memory.get_relation db ~name:"sakura:domain" with - | None -> assert false - | Some r -> r - in - assert (Manipulation.Memory.tuple_count dom_rel = 4)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let dom_rel = + match Manipulation.Memory.get_relation db ~name:"sakura:domain" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count dom_rel = 4)) let%test_unit "catalog: create_relation updates sakura:relation" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let schema = Schema.empty |> Schema.add "id" "natural" in - let db = match Manipulation.Memory.create_relation storage db ~name:"employees" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let rel = match Manipulation.Memory.get_relation db ~name:"sakura:relation" with - | None -> assert false | Some r -> r - in - (* 6 catalog relations + 1 user relation *) - assert (Manipulation.Memory.tuple_count rel = 7)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let schema = Schema.empty |> Schema.add "id" "natural" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"employees" + ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let rel = + match + Manipulation.Memory.get_relation db ~name:"sakura:relation" + with + | None -> assert false + | Some r -> r + in + (* 6 catalog relations + 1 user relation *) + assert (Manipulation.Memory.tuple_count rel = 7)) let%test_unit "catalog: create_relation updates sakura:attribute" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let schema = Schema.empty |> Schema.add "id" "natural" in - let db = match Manipulation.Memory.create_relation storage db ~name:"employees" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let attr_rel = match Manipulation.Memory.get_relation db ~name:"sakura:attribute" with - | None -> assert false | Some r -> r - in - (* catalog attribute tuples (sum of schema sizes of all 6 catalog relations) + 1 for employees *) - (* sakura:relation: 1, sakura:domain: 1, sakura:attribute: 3, sakura:constraint: 2, + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let schema = Schema.empty |> Schema.add "id" "natural" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"employees" + ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let attr_rel = + match + Manipulation.Memory.get_relation db ~name:"sakura:attribute" + with + | None -> assert false + | Some r -> r + in + (* catalog attribute tuples (sum of schema sizes of all 6 catalog relations) + 1 for employees *) + (* sakura:relation: 1, sakura:domain: 1, sakura:attribute: 3, sakura:constraint: 2, sakura:on: 1, sakura:timing: 1 => 9 catalog attrs + 1 for employees = 10 *) - let count = Manipulation.Memory.tuple_count attr_rel in - assert (count = 10)) + let count = Manipulation.Memory.tuple_count attr_rel in + assert (count = 10)) let%test_unit "catalog: retract_relation removes from sakura:relation" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let schema = Schema.empty |> Schema.add "id" "natural" in - let db = match Manipulation.Memory.create_relation storage db ~name:"employees" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let db = match Manipulation.Memory.retract_relation storage db ~name:"employees" with - | Error _ -> assert false | Ok db -> db - in - let rel = match Manipulation.Memory.get_relation db ~name:"sakura:relation" with - | None -> assert false | Some r -> r - in - (* Back to 6 catalog relations *) - assert (Manipulation.Memory.tuple_count rel = 6)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let schema = Schema.empty |> Schema.add "id" "natural" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"employees" + ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let db = + match + Manipulation.Memory.retract_relation storage db ~name:"employees" + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match + Manipulation.Memory.get_relation db ~name:"sakura:relation" + with + | None -> assert false + | Some r -> r + in + (* Back to 6 catalog relations *) + assert (Manipulation.Memory.tuple_count rel = 6)) let%test_unit "catalog: register_constraint inserts into sakura:constraint" = with_storage (fun storage -> - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> - let schema = Schema.empty |> Schema.add "id" "natural" in - let db = match Manipulation.Memory.create_relation storage db ~name:"orders" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let db = match Manipulation.Memory.register_constraint storage db - ~constraint_name:"orders_id_positive" - ~relation_name:"orders" - ~body:(Constraint.And []) with - | Error _ -> assert false | Ok db -> db - in - let con_rel = match Manipulation.Memory.get_relation db ~name:"sakura:constraint" with - | None -> assert false | Some r -> r - in - assert (Manipulation.Memory.tuple_count con_rel = 1)) + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> + let schema = Schema.empty |> Schema.add "id" "natural" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"orders" + ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"orders_id_positive" ~relation_name:"orders" + ~body:(Constraint.And []) + with + | Error _ -> assert false + | Ok db -> db + in + let con_rel = + match + Manipulation.Memory.get_relation db ~name:"sakura:constraint" + with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count con_rel = 1)) let%test_unit "integration: full workflow with storage" = with_storage (fun storage -> - (* Create database *) - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - - (* Create products relation *) - let schema = Schema.empty - |> Schema.add "id" "integer" - |> Schema.add "name" "string" - |> Schema.add "price" "integer" in + (* Create database *) + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in - let (db, products) = match Manipulation.Memory.create_relation storage db ~name:"products" ~schema with - | Error _ -> assert false - | Ok x -> x - in + (* Create products relation *) + let schema = + Schema.empty |> Schema.add "id" "integer" |> Schema.add "name" "string" + |> Schema.add "price" "integer" + in - (* Insert some products *) - let make_product id name price = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "id" { Attribute.value = Obj.magic id } - |> Tuple.AttributeMap.add "name" { Attribute.value = Obj.magic name } - |> Tuple.AttributeMap.add "price" { Attribute.value = Obj.magic price } in - ({ Tuple.relation = "products"; attributes = attrs } : Tuple.materialized) - in + let db, products = + match + Manipulation.Memory.create_relation storage db ~name:"products" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in - let tuples = [ - make_product 1 "Apple" 100; - make_product 2 "Banana" 50; - make_product 3 "Cherry" 200; - ] in + (* Insert some products *) + let make_product id name price = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "id" { Attribute.value = Obj.magic id } + |> Tuple.AttributeMap.add "name" { Attribute.value = Obj.magic name } + |> Tuple.AttributeMap.add "price" + { Attribute.value = Obj.magic price } + in + ({ Tuple.relation = "products"; attributes = attrs } + : Tuple.materialized) + in - let (db, products, hashes) = match Manipulation.Memory.create_tuples storage db products tuples with - | Error _ -> assert false - | Ok x -> x - in + let tuples = + [ + make_product 1 "Apple" 100; + make_product 2 "Banana" 50; + make_product 3 "Cherry" 200; + ] + in - assert (Manipulation.Memory.tuple_count products = 3); - assert (List.length hashes = 3); + let db, products, hashes = + match Manipulation.Memory.create_tuples storage db products tuples with + | Error _ -> assert false + | Ok x -> x + in - (* Verify we can load all tuples back *) - (match Manipulation.Memory.load_tuples storage hashes with - | Error _ -> assert false - | Ok loaded -> assert (List.length loaded = 3)); + assert (Manipulation.Memory.tuple_count products = 3); + assert (List.length hashes = 3); - (* Delete one product *) - let banana_hash = Manipulation.hash_tuple (make_product 2 "Banana" 50) in - let (_db, products) = match Manipulation.Memory.retract_tuple storage db products ~tuple_hash:banana_hash with + (* Verify we can load all tuples back *) + (match Manipulation.Memory.load_tuples storage hashes with | Error _ -> assert false - | Ok x -> x - in + | Ok loaded -> assert (List.length loaded = 3)); + + (* Delete one product *) + let banana_hash = Manipulation.hash_tuple (make_product 2 "Banana" 50) in + let _db, products = + match + Manipulation.Memory.retract_tuple storage db products + ~tuple_hash:banana_hash + with + | Error _ -> assert false + | Ok x -> x + in - assert (Manipulation.Memory.tuple_count products = 2); + assert (Manipulation.Memory.tuple_count products = 2); - (* Verify remaining hashes *) - let remaining_hashes = Manipulation.Memory.tuple_hashes products in - assert (List.length remaining_hashes = 2); - assert (not (List.mem banana_hash remaining_hashes)); + (* Verify remaining hashes *) + let remaining_hashes = Manipulation.Memory.tuple_hashes products in + assert (List.length remaining_hashes = 2); + assert (not (List.mem banana_hash remaining_hashes)); - (* But banana data is still in storage (append-only) *) - match Manipulation.Memory.load_tuple storage banana_hash with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded) -> - let name_attr = Tuple.AttributeMap.find "name" loaded.attributes in - assert ((Obj.magic name_attr.Attribute.value : string) = "Banana")) + (* But banana data is still in storage (append-only) *) + match Manipulation.Memory.load_tuple storage banana_hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded) -> + let name_attr = Tuple.AttributeMap.find "name" loaded.attributes in + assert ((Obj.magic name_attr.Attribute.value : string) = "Banana")) let%test_unit "integration: database history tracking" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"versioned" with - | Error _ -> assert false | Ok db -> db - in - let initial_hash = db.hash in + let db = + match Manipulation.Memory.create_database storage ~name:"versioned" with + | Error _ -> assert false + | Ok db -> db + in + let initial_hash = db.hash in - let schema = Schema.empty in - let (db, _) = match Manipulation.Memory.create_relation storage db ~name:"rel1" ~schema with - | Error _ -> assert false - | Ok x -> x - in + let schema = Schema.empty in + let db, _ = + match + Manipulation.Memory.create_relation storage db ~name:"rel1" ~schema + with + | Error _ -> assert false + | Ok x -> x + in - (* After first change, initial hash should be in history *) - assert (db.hash <> initial_hash); + (* After first change, initial hash should be in history *) + assert (db.hash <> initial_hash); - let hash_after_rel1 = db.hash in + let hash_after_rel1 = db.hash in - let (db, _) = match Manipulation.Memory.create_relation storage db ~name:"rel2" ~schema with - | Error _ -> assert false - | Ok x -> x - in + let db, _ = + match + Manipulation.Memory.create_relation storage db ~name:"rel2" ~schema + with + | Error _ -> assert false + | Ok x -> x + in - (* After second change, previous hash should be in history *) - assert (db.hash <> hash_after_rel1); - assert (List.mem hash_after_rel1 db.history)) + (* After second change, previous hash should be in history *) + assert (db.hash <> hash_after_rel1); + assert (List.mem hash_after_rel1 db.history)) let%test_unit "integration: hash bubbles up correctly" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in - let (db, relation) = match Manipulation.Memory.create_relation storage db ~name:"items" ~schema with - | Error _ -> assert false - | Ok x -> x - in + let db, relation = + match + Manipulation.Memory.create_relation storage db ~name:"items" ~schema + with + | Error _ -> assert false + | Ok x -> x + in - let db_hash_before = db.hash in - let rel_hash_before = relation.hash in + let db_hash_before = db.hash in + let rel_hash_before = relation.hash in - (* Insert a tuple *) - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 1 } in - let tuple : Tuple.materialized = { relation = "items"; attributes = attrs } in + (* Insert a tuple *) + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 1 } + in + let tuple : Tuple.materialized = + { relation = "items"; attributes = attrs } + in - let (db, relation, _) = match Manipulation.Memory.create_tuple storage db relation tuple with - | Error _ -> assert false - | Ok x -> x - in + let db, relation, _ = + match Manipulation.Memory.create_tuple storage db relation tuple with + | Error _ -> assert false + | Ok x -> x + in - (* Relation hash should change *) - assert (relation.hash <> rel_hash_before); + (* Relation hash should change *) + assert (relation.hash <> rel_hash_before); - (* Database hash should change *) - assert (db.hash <> db_hash_before); + (* Database hash should change *) + assert (db.hash <> db_hash_before); - (* Old database hash should be in history *) - assert (List.mem db_hash_before db.history); + (* Old database hash should be in history *) + assert (List.mem db_hash_before db.history); - (* Database's merkle tree should contain the new relation hash *) - match relation.hash with - | None -> assert false - | Some rel_hash -> - assert (Merkle.member rel_hash db.tree)) + (* Database's merkle tree should contain the new relation hash *) + match relation.hash with + | None -> assert false + | Some rel_hash -> assert (Merkle.member rel_hash db.tree)) let%test_unit "branching: load database from historical hash" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in - (* Create relation and add a tuple *) - let (db, relation) = match Manipulation.Memory.create_relation storage db ~name:"items" ~schema with - | Error _ -> assert false - | Ok x -> x - in + (* Create relation and add a tuple *) + let db, relation = + match + Manipulation.Memory.create_relation storage db ~name:"items" ~schema + with + | Error _ -> assert false + | Ok x -> x + in - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 1 } in - let tuple : Tuple.materialized = { relation = "items"; attributes = attrs } in + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 1 } + in + let tuple : Tuple.materialized = + { relation = "items"; attributes = attrs } + in - let (db, _relation, _) = match Manipulation.Memory.create_tuple storage db relation tuple with - | Error _ -> assert false - | Ok x -> x - in + let db, _relation, _ = + match Manipulation.Memory.create_tuple storage db relation tuple with + | Error _ -> assert false + | Ok x -> x + in - (* Capture hash H1 - database with 1 tuple *) - let h1 = db.hash in + (* Capture hash H1 - database with 1 tuple *) + let h1 = db.hash in - (* Add another tuple *) - let attrs2 = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 2 } in - let tuple2 : Tuple.materialized = { relation = "items"; attributes = attrs2 } in + (* Add another tuple *) + let attrs2 = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "x" { Attribute.value = Obj.magic 2 } + in + let tuple2 : Tuple.materialized = + { relation = "items"; attributes = attrs2 } + in - (* Get relation from database - it's now integrated! *) - let relation = match Manipulation.Memory.get_relation db ~name:"items" with - | None -> assert false - | Some r -> r - in + (* Get relation from database - it's now integrated! *) + let relation = + match Manipulation.Memory.get_relation db ~name:"items" with + | None -> assert false + | Some r -> r + in - let (db, _relation, _) = match Manipulation.Memory.create_tuple storage db relation tuple2 with - | Error _ -> assert false - | Ok x -> x - in + let db, _relation, _ = + match Manipulation.Memory.create_tuple storage db relation tuple2 with + | Error _ -> assert false + | Ok x -> x + in - let h2 = db.hash in - assert (h1 <> h2); + let h2 = db.hash in + assert (h1 <> h2); - (* Now load H1 from storage - should get database state with 1 tuple *) - match Manipulation.Memory.load_database storage h1 with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded_db) -> - assert (loaded_db.hash = h1); - assert (loaded_db.name = "test"); - (* The relation is now loaded directly in the database *) - match Manipulation.Memory.get_relation loaded_db ~name:"items" with - | None -> assert false - | Some loaded_rel -> - (* Should have 1 tuple *) - assert (Manipulation.Memory.tuple_count loaded_rel = 1)) + (* Now load H1 from storage - should get database state with 1 tuple *) + match Manipulation.Memory.load_database storage h1 with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded_db) -> ( + assert (loaded_db.hash = h1); + assert (loaded_db.name = "test"); + (* The relation is now loaded directly in the database *) + match Manipulation.Memory.get_relation loaded_db ~name:"items" with + | None -> assert false + | Some loaded_rel -> + (* Should have 1 tuple *) + assert (Manipulation.Memory.tuple_count loaded_rel = 1))) let%test_unit "branching: branch from historical state" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in - (* Create relation *) - let (db, relation) = match Manipulation.Memory.create_relation storage db ~name:"data" ~schema with - | Error _ -> assert false - | Ok x -> x - in + (* Create relation *) + let db, relation = + match + Manipulation.Memory.create_relation storage db ~name:"data" ~schema + with + | Error _ -> assert false + | Ok x -> x + in - (* Add tuple A *) - let tuple_a : Tuple.materialized = { - relation = "data"; - attributes = Tuple.AttributeMap.singleton "v" { Attribute.value = Obj.magic "A" } - } in - let (db, relation, _) = match Manipulation.Memory.create_tuple storage db relation tuple_a with - | Error _ -> assert false - | Ok x -> x - in + (* Add tuple A *) + let tuple_a : Tuple.materialized = + { + relation = "data"; + attributes = + Tuple.AttributeMap.singleton "v" { Attribute.value = Obj.magic "A" }; + } + in + let db, relation, _ = + match Manipulation.Memory.create_tuple storage db relation tuple_a with + | Error _ -> assert false + | Ok x -> x + in - (* Capture H1 - state with tuple A *) - let h1 = db.hash in + (* Capture H1 - state with tuple A *) + let h1 = db.hash in - (* Continue on main branch: add tuple B *) - let tuple_b : Tuple.materialized = { - relation = "data"; - attributes = Tuple.AttributeMap.singleton "v" { Attribute.value = Obj.magic "B" } - } in - let (db_main, relation_main, _) = match Manipulation.Memory.create_tuple storage db relation tuple_b with - | Error _ -> assert false - | Ok x -> x - in - let h2 = db_main.hash in + (* Continue on main branch: add tuple B *) + let tuple_b : Tuple.materialized = + { + relation = "data"; + attributes = + Tuple.AttributeMap.singleton "v" { Attribute.value = Obj.magic "B" }; + } + in + let db_main, relation_main, _ = + match Manipulation.Memory.create_tuple storage db relation tuple_b with + | Error _ -> assert false + | Ok x -> x + in + let h2 = db_main.hash in - (* Now branch from H1 and add tuple C instead *) - let db_branch = match Manipulation.Memory.load_database storage h1 with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some d) -> d - in - (* Relation is now loaded directly in the database *) - let relation_branch = match Manipulation.Memory.get_relation db_branch ~name:"data" with - | None -> assert false - | Some r -> r - in + (* Now branch from H1 and add tuple C instead *) + let db_branch = + match Manipulation.Memory.load_database storage h1 with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some d) -> d + in + (* Relation is now loaded directly in the database *) + let relation_branch = + match Manipulation.Memory.get_relation db_branch ~name:"data" with + | None -> assert false + | Some r -> r + in - let tuple_c : Tuple.materialized = { - relation = "data"; - attributes = Tuple.AttributeMap.singleton "v" { Attribute.value = Obj.magic "C" } - } in - let (db_branch, _relation_branch, _) = match Manipulation.Memory.create_tuple storage db_branch relation_branch tuple_c with - | Error _ -> assert false - | Ok x -> x - in - let h3 = db_branch.hash in + let tuple_c : Tuple.materialized = + { + relation = "data"; + attributes = + Tuple.AttributeMap.singleton "v" { Attribute.value = Obj.magic "C" }; + } + in + let db_branch, _relation_branch, _ = + match + Manipulation.Memory.create_tuple storage db_branch relation_branch + tuple_c + with + | Error _ -> assert false + | Ok x -> x + in + let h3 = db_branch.hash in - (* Verify: H1, H2, H3 are all different *) - assert (h1 <> h2); - assert (h1 <> h3); - assert (h2 <> h3); + (* Verify: H1, H2, H3 are all different *) + assert (h1 <> h2); + assert (h1 <> h3); + assert (h2 <> h3); - (* H2 (main branch) has tuples A and B *) - assert (Manipulation.Memory.tuple_count relation_main = 2); + (* H2 (main branch) has tuples A and B *) + assert (Manipulation.Memory.tuple_count relation_main = 2); - (* H1 is still loadable and unchanged *) - match Manipulation.Memory.load_database storage h1 with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded_h1) -> - match Manipulation.Memory.get_relation loaded_h1 ~name:"data" with - | None -> assert false - | Some r -> - assert (Manipulation.Memory.tuple_count r = 1)) + (* H1 is still loadable and unchanged *) + match Manipulation.Memory.load_database storage h1 with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded_h1) -> ( + match Manipulation.Memory.get_relation loaded_h1 ~name:"data" with + | None -> assert false + | Some r -> assert (Manipulation.Memory.tuple_count r = 1))) let%test_unit "branching: full reconstruction from hash" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - - (* Create relation *) - let (db, relation) = match Manipulation.Memory.create_relation storage db ~name:"products" ~schema with - | Error _ -> assert false - | Ok x -> x - in + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in + + (* Create relation *) + let db, relation = + match + Manipulation.Memory.create_relation storage db ~name:"products" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in - (* Add products *) - let make_product name = - { Tuple.relation = "products"; - attributes = Tuple.AttributeMap.singleton "name" { Attribute.value = Obj.magic name } } - in - let (db, _relation, _) = match Manipulation.Memory.create_tuples storage db relation - [make_product "Apple"; make_product "Banana"; make_product "Cherry"] with - | Error _ -> assert false - | Ok x -> x - in + (* Add products *) + let make_product name = + { + Tuple.relation = "products"; + attributes = + Tuple.AttributeMap.singleton "name" + { Attribute.value = Obj.magic name }; + } + in + let db, _relation, _ = + match + Manipulation.Memory.create_tuples storage db relation + [ + make_product "Apple"; make_product "Banana"; make_product "Cherry"; + ] + with + | Error _ -> assert false + | Ok x -> x + in - let saved_hash = db.hash in + let saved_hash = db.hash in - (* Now reconstruct everything from just the hash *) - match Manipulation.Memory.load_database storage saved_hash with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some loaded_db) -> - (* Relation is now loaded directly in the database *) - match Manipulation.Memory.get_relation loaded_db ~name:"products" with - | None -> assert false - | Some loaded_rel -> - (* Get tuple hashes from relation *) - let tuple_hashes = Manipulation.Memory.tuple_hashes loaded_rel in - assert (List.length tuple_hashes = 3); - - (* Load all tuples *) - match Manipulation.Memory.load_tuples storage tuple_hashes with - | Error _ -> assert false - | Ok tuples -> - assert (List.length tuples = 3); - let names = List.map (fun t -> - let attr = Tuple.AttributeMap.find "name" t.Tuple.attributes in - (Obj.magic attr.Attribute.value : string) - ) tuples in - assert (List.mem "Apple" names); - assert (List.mem "Banana" names); - assert (List.mem "Cherry" names)) + (* Now reconstruct everything from just the hash *) + match Manipulation.Memory.load_database storage saved_hash with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some loaded_db) -> ( + (* Relation is now loaded directly in the database *) + match Manipulation.Memory.get_relation loaded_db ~name:"products" with + | None -> assert false + | Some loaded_rel -> ( + (* Get tuple hashes from relation *) + let tuple_hashes = Manipulation.Memory.tuple_hashes loaded_rel in + assert (List.length tuple_hashes = 3); + + (* Load all tuples *) + match Manipulation.Memory.load_tuples storage tuple_hashes with + | Error _ -> assert false + | Ok tuples -> + assert (List.length tuples = 3); + let names = + List.map + (fun t -> + let attr = + Tuple.AttributeMap.find "name" t.Tuple.attributes + in + (Obj.magic attr.Attribute.value : string)) + tuples + in + assert (List.mem "Apple" names); + assert (List.mem "Banana" names); + assert (List.mem "Cherry" names)))) (* Helper: build a materialized tuple with int attributes *) let make_int_tuple relation pairs = let attributes = - List.fold_left (fun acc (k, v) -> - Tuple.AttributeMap.add k { Attribute.value = Obj.repr (v : int) } acc) + List.fold_left + (fun acc (k, v) -> + Tuple.AttributeMap.add k { Attribute.value = Obj.repr (v : int) } acc) Tuple.AttributeMap.empty pairs in (Tuple.Materialized { Tuple.relation; attributes } : Tuple.t) @@ -1024,289 +1257,429 @@ let make_int_tuple relation pairs = (* Helper: build a stored relation with one integer column and given values *) let stored_relation_with_ints storage db ~name ~attr values = let schema = Schema.empty |> Schema.add attr "integer" in - let (db, rel) = match Manipulation.Memory.create_relation storage db ~name ~schema with - | Error _ -> assert false | Ok x -> x + let db, rel = + match Manipulation.Memory.create_relation storage db ~name ~schema with + | Error _ -> assert false + | Ok x -> x in - let tuples = List.map (fun v -> - let attributes = - Tuple.AttributeMap.singleton attr { Attribute.value = Obj.repr (v : int) } - in - ({ Tuple.relation = name; attributes } : Tuple.materialized) - ) values in - let (db, rel, _) = match Manipulation.Memory.create_tuples storage db rel tuples with - | Error _ -> assert false | Ok x -> x + let tuples = + List.map + (fun v -> + let attributes = + Tuple.AttributeMap.singleton attr + { Attribute.value = Obj.repr (v : int) } + in + ({ Tuple.relation = name; attributes } : Tuple.materialized)) + values + in + let db, rel, _ = + match Manipulation.Memory.create_tuples storage db rel tuples with + | Error _ -> assert false + | Ok x -> x in (db, rel) let%test_unit "algebra: const_relation single tuple" = with_storage (fun storage -> - let rel = Algebra.Memory.const_relation - [ "x", Obj.repr (42 : int); - "y", Obj.repr (99 : int) ] in - match Algebra.Memory.materialize storage rel with - | Error _ -> assert false - | Ok [tup] -> - let x: int = Obj.obj (Tuple.AttributeMap.find "x" tup.Tuple.attributes).Attribute.value in - assert (x = 42) - | Ok _ -> assert false) + let rel = + Algebra.Memory.const_relation + [ ("x", Obj.repr (42 : int)); ("y", Obj.repr (99 : int)) ] + in + match Algebra.Memory.materialize storage rel with + | Error _ -> assert false + | Ok [ tup ] -> + let x : int = + Obj.obj + (Tuple.AttributeMap.find "x" tup.Tuple.attributes).Attribute.value + in + assert (x = 42) + | Ok _ -> assert false) let%test_unit "algebra: select_fn with predicate" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (_, rel) = stored_relation_with_ints storage db ~name:"nums" ~attr:"n" [1;2;3;4;5] in - let predicate = function - | Tuple.Materialized t -> - let v: int = Obj.obj (Tuple.AttributeMap.find "n" t.Tuple.attributes).Attribute.value in - v > 3 - | _ -> false - in - match Algebra.Memory.select_fn storage predicate rel with - | Error _ -> assert false - | Ok result -> - match Algebra.Memory.materialize storage result with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let _, rel = + stored_relation_with_ints storage db ~name:"nums" ~attr:"n" + [ 1; 2; 3; 4; 5 ] + in + let predicate = function + | Tuple.Materialized t -> + let v : int = + Obj.obj + (Tuple.AttributeMap.find "n" t.Tuple.attributes).Attribute.value + in + v > 3 + | _ -> false + in + match Algebra.Memory.select_fn storage predicate rel with | Error _ -> assert false - | Ok rows -> - assert (List.length rows = 2); - List.iter (fun t -> - let v: int = Obj.obj (Tuple.AttributeMap.find "n" t.Tuple.attributes).Attribute.value in - assert (v > 3)) rows) + | Ok result -> ( + match Algebra.Memory.materialize storage result with + | Error _ -> assert false + | Ok rows -> + assert (List.length rows = 2); + List.iter + (fun t -> + let v : int = + Obj.obj + (Tuple.AttributeMap.find "n" t.Tuple.attributes) + .Attribute.value + in + assert (v > 3)) + rows)) let%test_unit "algebra: project restricts schema" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "a" "integer" |> Schema.add "b" "integer" in - let (db, rel) = match Manipulation.Memory.create_relation storage db ~name:"ab" ~schema with - | Error _ -> assert false | Ok x -> x - in - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "a" { Attribute.value = Obj.repr (1 : int) } - |> Tuple.AttributeMap.add "b" { Attribute.value = Obj.repr (2 : int) } in - let (_, rel, _) = match Manipulation.Memory.create_tuple storage db rel - { Tuple.relation = "ab"; attributes = attrs } with - | Error _ -> assert false | Ok x -> x - in - match Algebra.Memory.project storage ["a"] rel with - | Error _ -> assert false - | Ok projected -> - match Algebra.Memory.materialize storage projected with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = + Schema.empty |> Schema.add "a" "integer" |> Schema.add "b" "integer" + in + let db, rel = + match + Manipulation.Memory.create_relation storage db ~name:"ab" ~schema + with + | Error _ -> assert false + | Ok x -> x + in + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "a" { Attribute.value = Obj.repr (1 : int) } + |> Tuple.AttributeMap.add "b" { Attribute.value = Obj.repr (2 : int) } + in + let _, rel, _ = + match + Manipulation.Memory.create_tuple storage db rel + { Tuple.relation = "ab"; attributes = attrs } + with + | Error _ -> assert false + | Ok x -> x + in + match Algebra.Memory.project storage [ "a" ] rel with | Error _ -> assert false - | Ok [t] -> - assert (Tuple.AttributeMap.mem "a" t.Tuple.attributes); - assert (not (Tuple.AttributeMap.mem "b" t.Tuple.attributes)) - | Ok _ -> assert false) + | Ok projected -> ( + match Algebra.Memory.materialize storage projected with + | Error _ -> assert false + | Ok [ t ] -> + assert (Tuple.AttributeMap.mem "a" t.Tuple.attributes); + assert (not (Tuple.AttributeMap.mem "b" t.Tuple.attributes)) + | Ok _ -> assert false)) let%test_unit "algebra: rename changes attr names" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (_, rel) = stored_relation_with_ints storage db ~name:"r" ~attr:"x" [7] in - match Algebra.Memory.rename storage [("x", "y")] rel with - | Error _ -> assert false - | Ok renamed -> - match Algebra.Memory.materialize storage renamed with - | Error _ -> assert false - | Ok [t] -> - assert (not (Tuple.AttributeMap.mem "x" t.Tuple.attributes)); - assert (Tuple.AttributeMap.mem "y" t.Tuple.attributes); - let v: int = Obj.obj (Tuple.AttributeMap.find "y" t.Tuple.attributes).Attribute.value in - assert (v = 7) - | Ok _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let _, rel = + stored_relation_with_ints storage db ~name:"r" ~attr:"x" [ 7 ] + in + match Algebra.Memory.rename storage [ ("x", "y") ] rel with + | Error _ -> assert false + | Ok renamed -> ( + match Algebra.Memory.materialize storage renamed with + | Error _ -> assert false + | Ok [ t ] -> + assert (not (Tuple.AttributeMap.mem "x" t.Tuple.attributes)); + assert (Tuple.AttributeMap.mem "y" t.Tuple.attributes); + let v : int = + Obj.obj + (Tuple.AttributeMap.find "y" t.Tuple.attributes) + .Attribute.value + in + assert (v = 7) + | Ok _ -> assert false)) let%test_unit "algebra: equijoin merges matching tuples" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - (* left: {id=1, name="Alice"}, {id=2, name="Bob"} *) - let schema_l = Schema.empty |> Schema.add "id" "integer" |> Schema.add "name" "string" in - let (db, left) = match Manipulation.Memory.create_relation storage db ~name:"L" ~schema:schema_l with - | Error _ -> assert false | Ok x -> x - in - let make_left id name = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "id" { Attribute.value = Obj.repr (id : int) } - |> Tuple.AttributeMap.add "name" { Attribute.value = Obj.repr (name : string) } in - ({ Tuple.relation = "L"; attributes = attrs } : Tuple.materialized) - in - let (db, left, _) = match Manipulation.Memory.create_tuples storage db left - [make_left 1 "Alice"; make_left 2 "Bob"] with - | Error _ -> assert false | Ok x -> x - in - (* right: {id=1, score=100}, {id=3, score=999} *) - let schema_r = Schema.empty |> Schema.add "id" "integer" |> Schema.add "score" "integer" in - let (db, right) = match Manipulation.Memory.create_relation storage db ~name:"R" ~schema:schema_r with - | Error _ -> assert false | Ok x -> x - in - let make_right id score = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "id" { Attribute.value = Obj.repr (id : int) } - |> Tuple.AttributeMap.add "score" { Attribute.value = Obj.repr (score : int) } in - ({ Tuple.relation = "R"; attributes = attrs } : Tuple.materialized) - in - let (_, right, _) = match Manipulation.Memory.create_tuples storage db right - [make_right 1 100; make_right 3 999] with - | Error _ -> assert false | Ok x -> x - in - match Algebra.Memory.equijoin storage ["id"] left right with - | Error _ -> assert false - | Ok joined -> - match Algebra.Memory.materialize storage joined with - | Error _ -> assert false - | Ok rows -> - (* Only id=1 matches *) - assert (List.length rows = 1); - let t = List.hd rows in - let score: int = Obj.obj (Tuple.AttributeMap.find "score" t.Tuple.attributes).Attribute.value in - assert (score = 100)) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + (* left: {id=1, name="Alice"}, {id=2, name="Bob"} *) + let schema_l = + Schema.empty |> Schema.add "id" "integer" |> Schema.add "name" "string" + in + let db, left = + match + Manipulation.Memory.create_relation storage db ~name:"L" + ~schema:schema_l + with + | Error _ -> assert false + | Ok x -> x + in + let make_left id name = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "id" + { Attribute.value = Obj.repr (id : int) } + |> Tuple.AttributeMap.add "name" + { Attribute.value = Obj.repr (name : string) } + in + ({ Tuple.relation = "L"; attributes = attrs } : Tuple.materialized) + in + let db, left, _ = + match + Manipulation.Memory.create_tuples storage db left + [ make_left 1 "Alice"; make_left 2 "Bob" ] + with + | Error _ -> assert false + | Ok x -> x + in + (* right: {id=1, score=100}, {id=3, score=999} *) + let schema_r = + Schema.empty |> Schema.add "id" "integer" + |> Schema.add "score" "integer" + in + let db, right = + match + Manipulation.Memory.create_relation storage db ~name:"R" + ~schema:schema_r + with + | Error _ -> assert false + | Ok x -> x + in + let make_right id score = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "id" + { Attribute.value = Obj.repr (id : int) } + |> Tuple.AttributeMap.add "score" + { Attribute.value = Obj.repr (score : int) } + in + ({ Tuple.relation = "R"; attributes = attrs } : Tuple.materialized) + in + let _, right, _ = + match + Manipulation.Memory.create_tuples storage db right + [ make_right 1 100; make_right 3 999 ] + with + | Error _ -> assert false + | Ok x -> x + in + match Algebra.Memory.equijoin storage [ "id" ] left right with + | Error _ -> assert false + | Ok joined -> ( + match Algebra.Memory.materialize storage joined with + | Error _ -> assert false + | Ok rows -> + (* Only id=1 matches *) + assert (List.length rows = 1); + let t = List.hd rows in + let score : int = + Obj.obj + (Tuple.AttributeMap.find "score" t.Tuple.attributes) + .Attribute.value + in + assert (score = 100))) let%test_unit "algebra: equijoin empty match" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (db, left) = stored_relation_with_ints storage db ~name:"L" ~attr:"id" [1;2] in - let (_, right) = stored_relation_with_ints storage db ~name:"R" ~attr:"id" [9;8] in - match Algebra.Memory.equijoin storage ["id"] left right with - | Error _ -> assert false - | Ok joined -> - match Algebra.Memory.materialize storage joined with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let db, left = + stored_relation_with_ints storage db ~name:"L" ~attr:"id" [ 1; 2 ] + in + let _, right = + stored_relation_with_ints storage db ~name:"R" ~attr:"id" [ 9; 8 ] + in + match Algebra.Memory.equijoin storage [ "id" ] left right with | Error _ -> assert false - | Ok rows -> assert (List.length rows = 0)) + | Ok joined -> ( + match Algebra.Memory.materialize storage joined with + | Error _ -> assert false + | Ok rows -> assert (List.length rows = 0))) let%test_unit "algebra: union concatenates streams" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (db, r1) = stored_relation_with_ints storage db ~name:"A" ~attr:"n" [1;2] in - let (_, r2) = stored_relation_with_ints storage db ~name:"B" ~attr:"n" [3;4] in - match Algebra.Memory.union storage r1 r2 with - | Error _ -> assert false - | Ok unioned -> - match Algebra.Memory.materialize storage unioned with - | Error _ -> assert false - | Ok rows -> - assert (List.length rows = 4); - let vals = List.map (fun t -> - Obj.obj (Tuple.AttributeMap.find "n" t.Tuple.attributes).Attribute.value - ) rows in - assert (List.mem 1 vals); - assert (List.mem 2 vals); - assert (List.mem 3 vals); - assert (List.mem 4 vals)) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let db, r1 = + stored_relation_with_ints storage db ~name:"A" ~attr:"n" [ 1; 2 ] + in + let _, r2 = + stored_relation_with_ints storage db ~name:"B" ~attr:"n" [ 3; 4 ] + in + match Algebra.Memory.union storage r1 r2 with + | Error _ -> assert false + | Ok unioned -> ( + match Algebra.Memory.materialize storage unioned with + | Error _ -> assert false + | Ok rows -> + assert (List.length rows = 4); + let vals = + List.map + (fun t -> + Obj.obj + (Tuple.AttributeMap.find "n" t.Tuple.attributes) + .Attribute.value) + rows + in + assert (List.mem 1 vals); + assert (List.mem 2 vals); + assert (List.mem 3 vals); + assert (List.mem 4 vals))) let%test_unit "algebra: diff removes right from left" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (db, r1) = stored_relation_with_ints storage db ~name:"A" ~attr:"n" [1;2;3] in - let (_, r2) = stored_relation_with_ints storage db ~name:"B" ~attr:"n" [2;3] in - match Algebra.Memory.diff storage r1 r2 with - | Error _ -> assert false - | Ok result -> - match Algebra.Memory.materialize storage result with - | Error _ -> assert false - | Ok rows -> - assert (List.length rows = 1); - let v: int = Obj.obj (Tuple.AttributeMap.find "n" (List.hd rows).Tuple.attributes).Attribute.value in - assert (v = 1)) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let db, r1 = + stored_relation_with_ints storage db ~name:"A" ~attr:"n" [ 1; 2; 3 ] + in + let _, r2 = + stored_relation_with_ints storage db ~name:"B" ~attr:"n" [ 2; 3 ] + in + match Algebra.Memory.diff storage r1 r2 with + | Error _ -> assert false + | Ok result -> ( + match Algebra.Memory.materialize storage result with + | Error _ -> assert false + | Ok rows -> + assert (List.length rows = 1); + let v : int = + Obj.obj + (Tuple.AttributeMap.find "n" (List.hd rows).Tuple.attributes) + .Attribute.value + in + assert (v = 1))) let%test_unit "algebra: take limits output" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (_, rel) = stored_relation_with_ints storage db ~name:"big" ~attr:"n" [10;20;30;40;50] in - match Algebra.Memory.take storage 3 rel with - | Error _ -> assert false - | Ok result -> - match Algebra.Memory.materialize storage result with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + let _, rel = + stored_relation_with_ints storage db ~name:"big" ~attr:"n" + [ 10; 20; 30; 40; 50 ] + in + match Algebra.Memory.take storage 3 rel with | Error _ -> assert false - | Ok rows -> assert (List.length rows = 3)) + | Ok result -> ( + match Algebra.Memory.materialize storage result with + | Error _ -> assert false + | Ok rows -> assert (List.length rows = 3))) let%test_unit "drl: parse Base" = match Drl.Parser.of_string {|(Base "users")|} with - | Error _ -> assert false - | Ok (Drl.Ast.Base s) -> assert (s = "users") - | Ok _ -> assert false + | Error _ -> assert false + | Ok (Drl.Ast.Base s) -> assert (s = "users") + | Ok _ -> assert false let%test_unit "drl: parse Const" = match Drl.Parser.of_string {|(Const (("age" (Int 18))))|} with - | Error _ -> assert false - | Ok (Drl.Ast.Const [("age", Drl.Ast.Int 18)]) -> () - | Ok _ -> assert false + | Error _ -> assert false + | Ok (Drl.Ast.Const [ ("age", Drl.Ast.Int 18) ]) -> () + | Ok _ -> assert false let%test_unit "drl: parse Join" = match Drl.Parser.of_string {|(Join (id) (Base "L") (Base "R"))|} with - | Error _ -> assert false - | Ok (Drl.Ast.Join (["id"], Drl.Ast.Base "L", Drl.Ast.Base "R")) -> () - | Ok _ -> assert false + | Error _ -> assert false + | Ok (Drl.Ast.Join ([ "id" ], Drl.Ast.Base "L", Drl.Ast.Base "R")) -> () + | Ok _ -> assert false let%test_unit "drl: parse Select" = let s = {|(Select (Const (("age" (Int 18)))) (Base "users"))|} in match Drl.Parser.of_string s with | Error _ -> assert false | Ok (Drl.Ast.Select (Drl.Ast.Const _, Drl.Ast.Base "users")) -> () - | Ok _ -> assert false + | Ok _ -> assert false let%test_unit "drl: execute Base" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - let (db, _) = stored_relation_with_ints storage db ~name:"items" ~attr:"v" [10; 20] in - match Drl.Parser.of_string {|(Base "items")|} with - | Error _ -> assert false - | Ok query -> - match Drl.Executor.Memory.execute storage db query with - | Error _ -> assert false - | Ok rel -> - match Algebra.Memory.materialize storage rel with + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with | Error _ -> assert false - | Ok rows -> assert (List.length rows = 2)) + | Ok db -> db + in + let db, _ = + stored_relation_with_ints storage db ~name:"items" ~attr:"v" [ 10; 20 ] + in + match Drl.Parser.of_string {|(Base "items")|} with + | Error _ -> assert false + | Ok query -> ( + match Drl.Executor.Memory.execute storage db query with + | Error _ -> assert false + | Ok rel -> ( + match Algebra.Memory.materialize storage rel with + | Error _ -> assert false + | Ok rows -> assert (List.length rows = 2)))) let%test_unit "drl: execute Select+Const" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"test_db" with - | Error _ -> assert false | Ok db -> db - in - (* users: {age=18, name="Alice"}, {age=25, name="Bob"} *) - let schema = Schema.empty |> Schema.add "age" "integer" |> Schema.add "name" "string" in - let (db, users) = match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false | Ok x -> x - in - let make_user age name = - let attrs = Tuple.AttributeMap.empty - |> Tuple.AttributeMap.add "age" { Attribute.value = Obj.repr (age : int) } - |> Tuple.AttributeMap.add "name" { Attribute.value = Obj.repr (name : string) } in - ({ Tuple.relation = "users"; attributes = attrs } : Tuple.materialized) - in - let (db, _, _) = match Manipulation.Memory.create_tuples storage db users - [make_user 18 "Alice"; make_user 25 "Bob"] with - | Error _ -> assert false | Ok x -> x - in - (* Query: select users where age = 18 *) - let s = {|(Select (Const (("age" (Int 18)))) (Base "users"))|} in - match Drl.Parser.of_string s with - | Error _ -> assert false - | Ok query -> - match Drl.Executor.Memory.execute storage db query with - | Error _ -> assert false - | Ok rel -> - match Algebra.Memory.materialize storage rel with - | Error _ -> assert false - | Ok rows -> - assert (List.length rows = 1); - let name_v: string = - Obj.obj (Tuple.AttributeMap.find "name" (List.hd rows).Tuple.attributes).Attribute.value - in - assert (name_v = "Alice")) + let db = + match Manipulation.Memory.create_database storage ~name:"test_db" with + | Error _ -> assert false + | Ok db -> db + in + (* users: {age=18, name="Alice"}, {age=25, name="Bob"} *) + let schema = + Schema.empty |> Schema.add "age" "integer" |> Schema.add "name" "string" + in + let db, users = + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok x -> x + in + let make_user age name = + let attrs = + Tuple.AttributeMap.empty + |> Tuple.AttributeMap.add "age" + { Attribute.value = Obj.repr (age : int) } + |> Tuple.AttributeMap.add "name" + { Attribute.value = Obj.repr (name : string) } + in + ({ Tuple.relation = "users"; attributes = attrs } : Tuple.materialized) + in + let db, _, _ = + match + Manipulation.Memory.create_tuples storage db users + [ make_user 18 "Alice"; make_user 25 "Bob" ] + with + | Error _ -> assert false + | Ok x -> x + in + (* Query: select users where age = 18 *) + let s = {|(Select (Const (("age" (Int 18)))) (Base "users"))|} in + match Drl.Parser.of_string s with + | Error _ -> assert false + | Ok query -> ( + match Drl.Executor.Memory.execute storage db query with + | Error _ -> assert false + | Ok rel -> ( + match Algebra.Memory.materialize storage rel with + | Error _ -> assert false + | Ok rows -> + assert (List.length rows = 1); + let name_v : string = + Obj.obj + (Tuple.AttributeMap.find "name" + (List.hd rows).Tuple.attributes) + .Attribute.value + in + assert (name_v = "Alice")))) (* ---------- Constraint construction ---------- *) @@ -1322,12 +1695,8 @@ let%test_unit "constraint: vars_in MemberOf" = assert (not (List.mem "right" vars)) let%test_unit "constraint: vars_in And" = - let b1 = - Constraint.BindingMap.singleton "left" (Constraint.Var "a") - in - let b2 = - Constraint.BindingMap.singleton "left" (Constraint.Var "b") - in + let b1 = Constraint.BindingMap.singleton "left" (Constraint.Var "a") in + let b2 = Constraint.BindingMap.singleton "left" (Constraint.Var "b") in let c = Constraint.And [ @@ -1340,9 +1709,7 @@ let%test_unit "constraint: vars_in And" = assert (List.mem "b" vars) let%test_unit "constraint: rename_vars" = - let b = - Constraint.BindingMap.singleton "left" (Constraint.Var "old_name") - in + let b = Constraint.BindingMap.singleton "left" (Constraint.Var "old_name") in let c = Constraint.MemberOf { target = "t"; binding = b } in let c' = Constraint.rename_vars [ ("old_name", "new_name") ] c in let vars = Constraint.vars_in c' in @@ -1350,9 +1717,7 @@ let%test_unit "constraint: rename_vars" = assert (not (List.mem "old_name" vars)) let%test_unit "constraint: filter_by_attrs keeps relevant" = - let b = - Constraint.BindingMap.singleton "left" (Constraint.Var "x") - in + let b = Constraint.BindingMap.singleton "left" (Constraint.Var "x") in let c = Constraint.MemberOf { target = "t"; binding = b } in assert (Constraint.filter_by_attrs [ "x" ] c <> None); assert (Constraint.filter_by_attrs [ "y" ] c = None) @@ -1399,7 +1764,8 @@ let%test_unit "constraint: lt shorthand" = let%test_unit "constraint: between shorthand" = match - Constraint.between ~value:(Var "x") ~low:(Const (Obj.repr 0)) + Constraint.between ~value:(Var "x") + ~low:(Const (Obj.repr 0)) ~high:(Const (Obj.repr 100)) with | Constraint.And [ _; _ ] -> () @@ -1444,26 +1810,16 @@ let make_eval_ctx ?(relations = []) () : Constraint.eval_context = } let%test_unit "constraint: evaluate MemberOf success" = - let ctx = - make_eval_ctx - ~relations:[ ("my_rel", fun _pairs -> true) ] - () - in + let ctx = make_eval_ctx ~relations:[ ("my_rel", fun _pairs -> true) ] () in let b = Constraint.BindingMap.empty in let c = Constraint.MemberOf { target = "my_rel"; binding = b } in let tuple : Tuple.materialized = { relation = "test"; attributes = Tuple.AttributeMap.empty } in - match Constraint.evaluate ctx tuple c with - | Ok true -> () - | _ -> assert false + match Constraint.evaluate ctx tuple c with Ok true -> () | _ -> assert false let%test_unit "constraint: evaluate MemberOf failure" = - let ctx = - make_eval_ctx - ~relations:[ ("my_rel", fun _pairs -> false) ] - () - in + let ctx = make_eval_ctx ~relations:[ ("my_rel", fun _pairs -> false) ] () in let b = Constraint.BindingMap.empty in let c = Constraint.MemberOf { target = "my_rel"; binding = b } in let tuple : Tuple.materialized = @@ -1502,20 +1858,14 @@ let%test_unit "constraint: evaluate And short-circuits" = { relation = "test"; attributes = Tuple.AttributeMap.empty } in (match Constraint.evaluate ctx tuple c with - | Error _ -> () - | _ -> assert false); + | Error _ -> () + | _ -> assert false); (* Second branch should not have been called *) assert (!call_count = 1) let%test_unit "constraint: evaluate Or succeeds on first match" = let ctx = - make_eval_ctx - ~relations: - [ - ("a", fun _ -> false); - ("b", fun _ -> true); - ] - () + make_eval_ctx ~relations:[ ("a", fun _ -> false); ("b", fun _ -> true) ] () in let b = Constraint.BindingMap.empty in let c = @@ -1528,9 +1878,7 @@ let%test_unit "constraint: evaluate Or succeeds on first match" = let tuple : Tuple.materialized = { relation = "test"; attributes = Tuple.AttributeMap.empty } in - match Constraint.evaluate ctx tuple c with - | Ok true -> () - | _ -> assert false + match Constraint.evaluate ctx tuple c with Ok true -> () | _ -> assert false let%test_unit "constraint: evaluate Not negates" = let ctx : Constraint.eval_context = @@ -1555,16 +1903,14 @@ let%test_unit "constraint: evaluate Not negates" = let tuple : Tuple.materialized = { relation = "test"; attributes = Tuple.AttributeMap.empty } in - match Constraint.evaluate ctx tuple c with - | Ok true -> () - | _ -> assert false + match Constraint.evaluate ctx tuple c with Ok true -> () | _ -> assert false let%test_unit "constraint: evaluate Exists over finite relation" = let ctx : Constraint.eval_context = { check_membership = (fun _rel_name pairs -> - match List.assoc_opt "left" pairs, List.assoc_opt "right" pairs with + match (List.assoc_opt "left" pairs, List.assoc_opt "right" pairs) with | Some l, Some r -> (Obj.obj l : int) < (Obj.obj r : int) | _ -> false); iterate_finite = @@ -1600,26 +1946,20 @@ let%test_unit "constraint: evaluate Exists over finite relation" = Tuple.AttributeMap.singleton "x" { Attribute.value = Obj.repr 3 }; } in - match Constraint.evaluate ctx tuple c with - | Ok true -> () - | _ -> assert false + match Constraint.evaluate ctx tuple c with Ok true -> () | _ -> assert false let%test_unit "constraint: evaluate Forall fails when not all match" = let ctx : Constraint.eval_context = { check_membership = (fun _rel_name pairs -> - match List.assoc_opt "left" pairs, List.assoc_opt "right" pairs with + match (List.assoc_opt "left" pairs, List.assoc_opt "right" pairs) with | Some l, Some r -> (Obj.obj l : int) < (Obj.obj r : int) | _ -> false); iterate_finite = (fun rel_name -> if rel_name = "small_set" then - Some - [ - [ ("value", Obj.repr 1) ]; - [ ("value", Obj.repr 5) ]; - ] + Some [ [ ("value", Obj.repr 1) ]; [ ("value", Obj.repr 5) ] ] else None); } in @@ -1650,10 +1990,7 @@ let%test_unit "constraint: evaluate Forall fails when not all match" = let%test_unit "constraint: Forall unbounded quantifier errors" = let ctx : Constraint.eval_context = - { - check_membership = (fun _ _ -> true); - iterate_finite = (fun _ -> None); - } + { check_membership = (fun _ _ -> true); iterate_finite = (fun _ -> None) } in let b = Constraint.BindingMap.empty in let c = @@ -1675,667 +2012,659 @@ let%test_unit "constraint: Forall unbounded quantifier errors" = let%test_unit "constraint: create_tuple with passing constraint" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = Schema.empty |> Schema.add "value" "natural" in - let db, _rel = - match - Manipulation.Memory.create_relation storage db ~name:"positives" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - (* Register a constraint: value must be member of natural (always true for naturals) *) - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"is_natural" ~relation_name:"positives" - ~body:(Constraint.And []) - with - | Error _ -> assert false - | Ok db -> db - in - let rel = - match Manipulation.Memory.get_relation db ~name:"positives" with - | None -> assert false - | Some r -> r - in - let tuple : Tuple.materialized = - { - relation = "positives"; - attributes = - Tuple.AttributeMap.singleton "value" - { Attribute.value = Obj.repr 5 }; - } - in - match Manipulation.Memory.create_tuple storage db rel tuple with - | Ok _ -> () - | Error _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "value" "natural" in + let db, _rel = + match + Manipulation.Memory.create_relation storage db ~name:"positives" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in + (* Register a constraint: value must be member of natural (always true for naturals) *) + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"is_natural" ~relation_name:"positives" + ~body:(Constraint.And []) + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match Manipulation.Memory.get_relation db ~name:"positives" with + | None -> assert false + | Some r -> r + in + let tuple : Tuple.materialized = + { + relation = "positives"; + attributes = + Tuple.AttributeMap.singleton "value" + { Attribute.value = Obj.repr 5 }; + } + in + match Manipulation.Memory.create_tuple storage db rel tuple with + | Ok _ -> () + | Error _ -> assert false) let%test_unit "constraint: create_tuple with failing constraint" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = Schema.empty |> Schema.add "value" "natural" in - let db, _rel = - match - Manipulation.Memory.create_relation storage db ~name:"checked" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - (* Register a constraint that always fails: MemberOf a nonexistent relation *) - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"impossible" ~relation_name:"checked" - ~body: - (Constraint.MemberOf - { - target = "nonexistent_relation"; - binding = - Constraint.BindingMap.singleton "x" (Constraint.Var "value"); - }) - with - | Error _ -> assert false - | Ok db -> db - in - let rel = - match Manipulation.Memory.get_relation db ~name:"checked" with - | None -> assert false - | Some r -> r - in - let tuple : Tuple.materialized = - { - relation = "checked"; - attributes = - Tuple.AttributeMap.singleton "value" - { Attribute.value = Obj.repr 5 }; - } - in - match Manipulation.Memory.create_tuple storage db rel tuple with - | Error (Manipulation.ConstraintViolation _) -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "value" "natural" in + let db, _rel = + match + Manipulation.Memory.create_relation storage db ~name:"checked" ~schema + with + | Error _ -> assert false + | Ok x -> x + in + (* Register a constraint that always fails: MemberOf a nonexistent relation *) + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"impossible" ~relation_name:"checked" + ~body: + (Constraint.MemberOf + { + target = "nonexistent_relation"; + binding = + Constraint.BindingMap.singleton "x" + (Constraint.Var "value"); + }) + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match Manipulation.Memory.get_relation db ~name:"checked" with + | None -> assert false + | Some r -> r + in + let tuple : Tuple.materialized = + { + relation = "checked"; + attributes = + Tuple.AttributeMap.singleton "value" + { Attribute.value = Obj.repr 5 }; + } + in + match Manipulation.Memory.create_tuple storage db rel tuple with + | Error (Manipulation.ConstraintViolation _) -> () + | _ -> assert false) (* ---------- Scenario tests ported from Erlang ---------- *) (* Scenario 1: Mutual exclusion between subtypes *) let%test_unit "constraint scenario: mutual exclusion subtypes" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = Schema.empty |> Schema.add "id" "natural" in - let db, _employee = - match - Manipulation.Memory.create_relation storage db ~name:"employee" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - let db, _manager = - match - Manipulation.Memory.create_relation storage db ~name:"manager" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - (* manager must NOT be in employee (mutual exclusion) *) - let body = - Constraint.Not + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "id" "natural" in + let db, _employee = + match + Manipulation.Memory.create_relation storage db ~name:"employee" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in + let db, _manager = + match + Manipulation.Memory.create_relation storage db ~name:"manager" ~schema + with + | Error _ -> assert false + | Ok x -> x + in + (* manager must NOT be in employee (mutual exclusion) *) + let body = + Constraint.Not + { + body = + Constraint.MemberOf + { + target = "employee"; + binding = + Constraint.BindingMap.singleton "id" (Constraint.Var "id"); + }; + universe = "manager"; + } + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"not_employee" ~relation_name:"manager" ~body + with + | Error _ -> assert false + | Ok db -> db + in + (* Insert into employee first *) + let employee = + match Manipulation.Memory.get_relation db ~name:"employee" with + | None -> assert false + | Some r -> r + in + let emp_tuple : Tuple.materialized = { - body = - Constraint.MemberOf - { - target = "employee"; - binding = - Constraint.BindingMap.singleton "id" (Constraint.Var "id"); - }; - universe = "manager"; + relation = "employee"; + attributes = + Tuple.AttributeMap.singleton "id" { Attribute.value = Obj.repr 1 }; } - in - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"not_employee" ~relation_name:"manager" ~body - with - | Error _ -> assert false - | Ok db -> db - in - (* Insert into employee first *) - let employee = - match Manipulation.Memory.get_relation db ~name:"employee" with - | None -> assert false - | Some r -> r - in - let emp_tuple : Tuple.materialized = - { - relation = "employee"; - attributes = - Tuple.AttributeMap.singleton "id" - { Attribute.value = Obj.repr 1 }; - } - in - let db, _employee, _ = - match - Manipulation.Memory.create_tuple storage db employee emp_tuple - with - | Error _ -> assert false - | Ok x -> x - in - (* Now try to insert same id into manager, should fail *) - let manager = - match Manipulation.Memory.get_relation db ~name:"manager" with - | None -> assert false - | Some r -> r - in - let mgr_tuple : Tuple.materialized = - { - relation = "manager"; - attributes = - Tuple.AttributeMap.singleton "id" - { Attribute.value = Obj.repr 1 }; - } - in - match Manipulation.Memory.create_tuple storage db manager mgr_tuple with - | Error (Manipulation.ConstraintViolation _) -> () - | _ -> assert false) + in + let db, _employee, _ = + match + Manipulation.Memory.create_tuple storage db employee emp_tuple + with + | Error _ -> assert false + | Ok x -> x + in + (* Now try to insert same id into manager, should fail *) + let manager = + match Manipulation.Memory.get_relation db ~name:"manager" with + | None -> assert false + | Some r -> r + in + let mgr_tuple : Tuple.materialized = + { + relation = "manager"; + attributes = + Tuple.AttributeMap.singleton "id" { Attribute.value = Obj.repr 1 }; + } + in + match Manipulation.Memory.create_tuple storage db manager mgr_tuple with + | Error (Manipulation.ConstraintViolation _) -> () + | _ -> assert false) (* Scenario 2: Foreign key constraint *) let%test_unit "constraint scenario: foreign key" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let order_schema = Schema.empty |> Schema.add "order_id" "natural" in - let db, _orders = - match - Manipulation.Memory.create_relation storage db ~name:"orders" - ~schema:order_schema - with - | Error _ -> assert false - | Ok x -> x - in - let item_schema = - Schema.empty |> Schema.add "item_id" "natural" - |> Schema.add "order_id" "natural" - in - let db, _items = - match - Manipulation.Memory.create_relation storage db ~name:"order_items" - ~schema:item_schema - with - | Error _ -> assert false - | Ok x -> x - in - (* FK: order_items.order_id must exist in orders *) - let fk_body = - Constraint.MemberOf + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let order_schema = Schema.empty |> Schema.add "order_id" "natural" in + let db, _orders = + match + Manipulation.Memory.create_relation storage db ~name:"orders" + ~schema:order_schema + with + | Error _ -> assert false + | Ok x -> x + in + let item_schema = + Schema.empty + |> Schema.add "item_id" "natural" + |> Schema.add "order_id" "natural" + in + let db, _items = + match + Manipulation.Memory.create_relation storage db ~name:"order_items" + ~schema:item_schema + with + | Error _ -> assert false + | Ok x -> x + in + (* FK: order_items.order_id must exist in orders *) + let fk_body = + Constraint.MemberOf + { + target = "orders"; + binding = + Constraint.BindingMap.singleton "order_id" + (Constraint.Var "order_id"); + } + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"fk_order" ~relation_name:"order_items" + ~body:fk_body + with + | Error _ -> assert false + | Ok db -> db + in + (* Insert an order *) + let orders = + match Manipulation.Memory.get_relation db ~name:"orders" with + | None -> assert false + | Some r -> r + in + let order_tuple : Tuple.materialized = { - target = "orders"; - binding = - Constraint.BindingMap.singleton "order_id" - (Constraint.Var "order_id"); + relation = "orders"; + attributes = + Tuple.AttributeMap.singleton "order_id" + { Attribute.value = Obj.repr 100 }; } - in - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"fk_order" ~relation_name:"order_items" - ~body:fk_body - with - | Error _ -> assert false - | Ok db -> db - in - (* Insert an order *) - let orders = - match Manipulation.Memory.get_relation db ~name:"orders" with - | None -> assert false - | Some r -> r - in - let order_tuple : Tuple.materialized = - { - relation = "orders"; - attributes = - Tuple.AttributeMap.singleton "order_id" - { Attribute.value = Obj.repr 100 }; - } - in - let db, _orders, _ = - match - Manipulation.Memory.create_tuple storage db orders order_tuple - with - | Error _ -> assert false - | Ok x -> x - in - (* Insert item referencing valid order, should succeed *) - let items = - match Manipulation.Memory.get_relation db ~name:"order_items" with - | None -> assert false - | Some r -> r - in - let valid_item : Tuple.materialized = - { - relation = "order_items"; - attributes = - Tuple.AttributeMap.of_list - [ - ("item_id", { Attribute.value = Obj.repr 1 }); - ("order_id", { Attribute.value = Obj.repr 100 }); - ]; - } - in - let db, items, _ = - match - Manipulation.Memory.create_tuple storage db items valid_item - with - | Error _ -> assert false - | Ok x -> x - in - (* Insert item referencing nonexistent order, should fail *) - let invalid_item : Tuple.materialized = - { - relation = "order_items"; - attributes = - Tuple.AttributeMap.of_list - [ - ("item_id", { Attribute.value = Obj.repr 2 }); - ("order_id", { Attribute.value = Obj.repr 999 }); - ]; - } - in - match Manipulation.Memory.create_tuple storage db items invalid_item with - | Error (Manipulation.ConstraintViolation _) -> () - | _ -> assert false) + in + let db, _orders, _ = + match + Manipulation.Memory.create_tuple storage db orders order_tuple + with + | Error _ -> assert false + | Ok x -> x + in + (* Insert item referencing valid order, should succeed *) + let items = + match Manipulation.Memory.get_relation db ~name:"order_items" with + | None -> assert false + | Some r -> r + in + let valid_item : Tuple.materialized = + { + relation = "order_items"; + attributes = + Tuple.AttributeMap.of_list + [ + ("item_id", { Attribute.value = Obj.repr 1 }); + ("order_id", { Attribute.value = Obj.repr 100 }); + ]; + } + in + let db, items, _ = + match Manipulation.Memory.create_tuple storage db items valid_item with + | Error _ -> assert false + | Ok x -> x + in + (* Insert item referencing nonexistent order, should fail *) + let invalid_item : Tuple.materialized = + { + relation = "order_items"; + attributes = + Tuple.AttributeMap.of_list + [ + ("item_id", { Attribute.value = Obj.repr 2 }); + ("order_id", { Attribute.value = Obj.repr 999 }); + ]; + } + in + match Manipulation.Memory.create_tuple storage db items invalid_item with + | Error (Manipulation.ConstraintViolation _) -> () + | _ -> assert false) (* Scenario 3: Self-reference (emp_id != mgr_id via not_equal comparison) *) let%test_unit "constraint scenario: self-reference neq" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = - Schema.empty |> Schema.add "emp_id" "natural" - |> Schema.add "mgr_id" "natural" - in - let db, _rel = - match - Manipulation.Memory.create_relation storage db ~name:"reports_to" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - (* Register the not_equal comparison relation *) - let db, _ = - match - Manipulation.Memory.create_immutable_relation storage db - ~name:"not_equal" - ~schema: - (Schema.empty |> Schema.add "left" "natural" - |> Schema.add "right" "natural") - ~generator:(fun _ -> Generator.Error "not enumerable") - ~membership_criteria:(fun t -> - match t with - | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "left" m.attributes, - Tuple.AttributeMap.find_opt "right" m.attributes ) - with - | Some l, Some r -> - (Obj.obj l.Attribute.value : int) - <> (Obj.obj r.Attribute.value : int) + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = + Schema.empty + |> Schema.add "emp_id" "natural" + |> Schema.add "mgr_id" "natural" + in + let db, _rel = + match + Manipulation.Memory.create_relation storage db ~name:"reports_to" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in + (* Register the not_equal comparison relation *) + let db, _ = + match + Manipulation.Memory.create_immutable_relation storage db + ~name:"not_equal" + ~schema: + (Schema.empty + |> Schema.add "left" "natural" + |> Schema.add "right" "natural") + ~generator:(fun _ -> Generator.Error "not enumerable") + ~membership_criteria:(fun t -> + match t with + | Tuple.Materialized m -> ( + match + ( Tuple.AttributeMap.find_opt "left" m.attributes, + Tuple.AttributeMap.find_opt "right" m.attributes ) + with + | Some l, Some r -> + (Obj.obj l.Attribute.value : int) + <> (Obj.obj r.Attribute.value : int) + | _ -> false) | _ -> false) - | _ -> false) - ~cardinality:Conventions.Cardinality.AlephZero - with - | Error _ -> assert false - | Ok x -> x - in - (* Constraint: emp_id != mgr_id via not_equal relation *) - let neq_body = - Constraint.neq ~left:(Var "emp_id") ~right:(Var "mgr_id") - in - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"no_self_manage" ~relation_name:"reports_to" - ~body:neq_body - with - | Error _ -> assert false - | Ok db -> db - in - let rel = - match Manipulation.Memory.get_relation db ~name:"reports_to" with - | None -> assert false - | Some r -> r - in - (* Insert (emp_id=1, mgr_id=2), should succeed *) - let valid : Tuple.materialized = - { - relation = "reports_to"; - attributes = - Tuple.AttributeMap.of_list - [ - ("emp_id", { Attribute.value = Obj.repr 1 }); - ("mgr_id", { Attribute.value = Obj.repr 2 }); - ]; - } - in - let db, rel, _ = - match Manipulation.Memory.create_tuple storage db rel valid with - | Error _ -> assert false - | Ok x -> x - in - (* Insert (emp_id=3, mgr_id=3): same person, should fail *) - let invalid : Tuple.materialized = - { - relation = "reports_to"; - attributes = - Tuple.AttributeMap.of_list - [ - ("emp_id", { Attribute.value = Obj.repr 3 }); - ("mgr_id", { Attribute.value = Obj.repr 3 }); - ]; - } - in - match Manipulation.Memory.create_tuple storage db rel invalid with - | Error (Manipulation.ConstraintViolation _) -> () - | _ -> assert false) + ~cardinality:Conventions.Cardinality.AlephZero + with + | Error _ -> assert false + | Ok x -> x + in + (* Constraint: emp_id != mgr_id via not_equal relation *) + let neq_body = + Constraint.neq ~left:(Var "emp_id") ~right:(Var "mgr_id") + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"no_self_manage" ~relation_name:"reports_to" + ~body:neq_body + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match Manipulation.Memory.get_relation db ~name:"reports_to" with + | None -> assert false + | Some r -> r + in + (* Insert (emp_id=1, mgr_id=2), should succeed *) + let valid : Tuple.materialized = + { + relation = "reports_to"; + attributes = + Tuple.AttributeMap.of_list + [ + ("emp_id", { Attribute.value = Obj.repr 1 }); + ("mgr_id", { Attribute.value = Obj.repr 2 }); + ]; + } + in + let db, rel, _ = + match Manipulation.Memory.create_tuple storage db rel valid with + | Error _ -> assert false + | Ok x -> x + in + (* Insert (emp_id=3, mgr_id=3): same person, should fail *) + let invalid : Tuple.materialized = + { + relation = "reports_to"; + attributes = + Tuple.AttributeMap.of_list + [ + ("emp_id", { Attribute.value = Obj.repr 3 }); + ("mgr_id", { Attribute.value = Obj.repr 3 }); + ]; + } + in + match Manipulation.Memory.create_tuple storage db rel invalid with + | Error (Manipulation.ConstraintViolation _) -> () + | _ -> assert false) (* Scenario 4: Mutual exclusion between open_ticket and closed_ticket *) let%test_unit "constraint scenario: open vs closed ticket" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = Schema.empty |> Schema.add "ticket_id" "natural" in - let db, _ = - match - Manipulation.Memory.create_relation storage db ~name:"open_ticket" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - let db, _ = - match - Manipulation.Memory.create_relation storage db ~name:"closed_ticket" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - (* open_ticket must not be in closed_ticket *) - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"not_closed" ~relation_name:"open_ticket" - ~body: - (Constraint.Not - { - body = - Constraint.MemberOf - { - target = "closed_ticket"; - binding = - Constraint.BindingMap.singleton "ticket_id" - (Constraint.Var "ticket_id"); - }; - universe = "open_ticket"; - }) - with - | Error _ -> assert false - | Ok db -> db - in - (* Insert ticket 1 as closed *) - let closed = - match Manipulation.Memory.get_relation db ~name:"closed_ticket" with - | None -> assert false - | Some r -> r - in - let t1 : Tuple.materialized = - { - relation = "closed_ticket"; - attributes = - Tuple.AttributeMap.singleton "ticket_id" - { Attribute.value = Obj.repr 1 }; - } - in - let db, _, _ = - match Manipulation.Memory.create_tuple storage db closed t1 with - | Error _ -> assert false - | Ok x -> x - in - (* Try to open same ticket, should fail *) - let open_ = - match Manipulation.Memory.get_relation db ~name:"open_ticket" with - | None -> assert false - | Some r -> r - in - let t1_open : Tuple.materialized = - { - relation = "open_ticket"; - attributes = - Tuple.AttributeMap.singleton "ticket_id" - { Attribute.value = Obj.repr 1 }; - } - in - match Manipulation.Memory.create_tuple storage db open_ t1_open with - | Error (Manipulation.ConstraintViolation _) -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "ticket_id" "natural" in + let db, _ = + match + Manipulation.Memory.create_relation storage db ~name:"open_ticket" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in + let db, _ = + match + Manipulation.Memory.create_relation storage db ~name:"closed_ticket" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in + (* open_ticket must not be in closed_ticket *) + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"not_closed" ~relation_name:"open_ticket" + ~body: + (Constraint.Not + { + body = + Constraint.MemberOf + { + target = "closed_ticket"; + binding = + Constraint.BindingMap.singleton "ticket_id" + (Constraint.Var "ticket_id"); + }; + universe = "open_ticket"; + }) + with + | Error _ -> assert false + | Ok db -> db + in + (* Insert ticket 1 as closed *) + let closed = + match Manipulation.Memory.get_relation db ~name:"closed_ticket" with + | None -> assert false + | Some r -> r + in + let t1 : Tuple.materialized = + { + relation = "closed_ticket"; + attributes = + Tuple.AttributeMap.singleton "ticket_id" + { Attribute.value = Obj.repr 1 }; + } + in + let db, _, _ = + match Manipulation.Memory.create_tuple storage db closed t1 with + | Error _ -> assert false + | Ok x -> x + in + (* Try to open same ticket, should fail *) + let open_ = + match Manipulation.Memory.get_relation db ~name:"open_ticket" with + | None -> assert false + | Some r -> r + in + let t1_open : Tuple.materialized = + { + relation = "open_ticket"; + attributes = + Tuple.AttributeMap.singleton "ticket_id" + { Attribute.value = Obj.repr 1 }; + } + in + match Manipulation.Memory.create_tuple storage db open_ t1_open with + | Error (Manipulation.ConstraintViolation _) -> () + | _ -> assert false) (* Scenario 5: Weak entity dependency *) let%test_unit "constraint scenario: weak entity dependency" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let parent_schema = Schema.empty |> Schema.add "parent_id" "natural" in - let db, _ = - match - Manipulation.Memory.create_relation storage db ~name:"parent" - ~schema:parent_schema - with - | Error _ -> assert false - | Ok x -> x - in - let dep_schema = - Schema.empty |> Schema.add "dep_id" "natural" - |> Schema.add "parent_id" "natural" - in - let db, _ = - match - Manipulation.Memory.create_relation storage db ~name:"dependent" - ~schema:dep_schema - with - | Error _ -> assert false - | Ok x -> x - in - (* dependent.parent_id must exist in parent *) - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"parent_exists" ~relation_name:"dependent" - ~body: - (Constraint.MemberOf - { - target = "parent"; - binding = - Constraint.BindingMap.singleton "parent_id" - (Constraint.Var "parent_id"); - }) - with - | Error _ -> assert false - | Ok db -> db - in - (* Insert parent *) - let parent = - match Manipulation.Memory.get_relation db ~name:"parent" with - | None -> assert false - | Some r -> r - in - let pt : Tuple.materialized = - { - relation = "parent"; - attributes = - Tuple.AttributeMap.singleton "parent_id" - { Attribute.value = Obj.repr 10 }; - } - in - let db, _, _ = - match Manipulation.Memory.create_tuple storage db parent pt with - | Error _ -> assert false - | Ok x -> x - in - (* Insert dependent with valid parent, should succeed *) - let dep = - match Manipulation.Memory.get_relation db ~name:"dependent" with - | None -> assert false - | Some r -> r - in - let valid_dep : Tuple.materialized = - { - relation = "dependent"; - attributes = - Tuple.AttributeMap.of_list - [ - ("dep_id", { Attribute.value = Obj.repr 1 }); - ("parent_id", { Attribute.value = Obj.repr 10 }); - ]; - } - in - let db, dep, _ = - match - Manipulation.Memory.create_tuple storage db dep valid_dep - with - | Error _ -> assert false - | Ok x -> x - in - (* Insert dependent with nonexistent parent, should fail *) - let invalid_dep : Tuple.materialized = - { - relation = "dependent"; - attributes = - Tuple.AttributeMap.of_list - [ - ("dep_id", { Attribute.value = Obj.repr 2 }); - ("parent_id", { Attribute.value = Obj.repr 999 }); - ]; - } - in - match - Manipulation.Memory.create_tuple storage db dep invalid_dep - with - | Error (Manipulation.ConstraintViolation _) -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let parent_schema = Schema.empty |> Schema.add "parent_id" "natural" in + let db, _ = + match + Manipulation.Memory.create_relation storage db ~name:"parent" + ~schema:parent_schema + with + | Error _ -> assert false + | Ok x -> x + in + let dep_schema = + Schema.empty + |> Schema.add "dep_id" "natural" + |> Schema.add "parent_id" "natural" + in + let db, _ = + match + Manipulation.Memory.create_relation storage db ~name:"dependent" + ~schema:dep_schema + with + | Error _ -> assert false + | Ok x -> x + in + (* dependent.parent_id must exist in parent *) + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"parent_exists" ~relation_name:"dependent" + ~body: + (Constraint.MemberOf + { + target = "parent"; + binding = + Constraint.BindingMap.singleton "parent_id" + (Constraint.Var "parent_id"); + }) + with + | Error _ -> assert false + | Ok db -> db + in + (* Insert parent *) + let parent = + match Manipulation.Memory.get_relation db ~name:"parent" with + | None -> assert false + | Some r -> r + in + let pt : Tuple.materialized = + { + relation = "parent"; + attributes = + Tuple.AttributeMap.singleton "parent_id" + { Attribute.value = Obj.repr 10 }; + } + in + let db, _, _ = + match Manipulation.Memory.create_tuple storage db parent pt with + | Error _ -> assert false + | Ok x -> x + in + (* Insert dependent with valid parent, should succeed *) + let dep = + match Manipulation.Memory.get_relation db ~name:"dependent" with + | None -> assert false + | Some r -> r + in + let valid_dep : Tuple.materialized = + { + relation = "dependent"; + attributes = + Tuple.AttributeMap.of_list + [ + ("dep_id", { Attribute.value = Obj.repr 1 }); + ("parent_id", { Attribute.value = Obj.repr 10 }); + ]; + } + in + let db, dep, _ = + match Manipulation.Memory.create_tuple storage db dep valid_dep with + | Error _ -> assert false + | Ok x -> x + in + (* Insert dependent with nonexistent parent, should fail *) + let invalid_dep : Tuple.materialized = + { + relation = "dependent"; + attributes = + Tuple.AttributeMap.of_list + [ + ("dep_id", { Attribute.value = Obj.repr 2 }); + ("parent_id", { Attribute.value = Obj.repr 999 }); + ]; + } + in + match Manipulation.Memory.create_tuple storage db dep invalid_dep with + | Error (Manipulation.ConstraintViolation _) -> () + | _ -> assert false) (* Scenario 6: Algebra propagation, select preserves constraints *) let%test_unit "constraint propagation: select preserves constraints" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = Schema.empty |> Schema.add "x" "natural" in - let db, _rel = - match - Manipulation.Memory.create_relation storage db ~name:"constrained" - ~schema - with - | Error _ -> assert false - | Ok x -> x - in - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"c1" ~relation_name:"constrained" - ~body:(Constraint.And []) - with + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "x" "natural" in + let db, _rel = + match + Manipulation.Memory.create_relation storage db ~name:"constrained" + ~schema + with + | Error _ -> assert false + | Ok x -> x + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"c1" ~relation_name:"constrained" + ~body:(Constraint.And []) + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match Manipulation.Memory.get_relation db ~name:"constrained" with + | None -> assert false + | Some r -> r + in + match Algebra.Memory.select_fn storage (fun _ -> true) rel with | Error _ -> assert false - | Ok db -> db - in - let rel = - match Manipulation.Memory.get_relation db ~name:"constrained" with - | None -> assert false - | Some r -> r - in - match - Algebra.Memory.select_fn storage (fun _ -> true) rel - with - | Error _ -> assert false - | Ok result -> - assert (result.Relation.constraints <> None)) + | Ok result -> assert (result.Relation.constraints <> None)) (* Scenario 7: Algebra propagation, project filters constraints *) let%test_unit "constraint propagation: project filters constraints" = with_storage (fun storage -> - let db = - match Manipulation.Memory.create_database storage ~name:"test" with - | Error _ -> assert false - | Ok db -> db - in - let schema = - Schema.empty |> Schema.add "x" "natural" |> Schema.add "y" "natural" - in - let db, _rel = - match - Manipulation.Memory.create_relation storage db ~name:"xy" ~schema - with + let db = + match Manipulation.Memory.create_database storage ~name:"test" with + | Error _ -> assert false + | Ok db -> db + in + let schema = + Schema.empty |> Schema.add "x" "natural" |> Schema.add "y" "natural" + in + let db, _rel = + match + Manipulation.Memory.create_relation storage db ~name:"xy" ~schema + with + | Error _ -> assert false + | Ok x -> x + in + (* Constraint on x only *) + let c_on_x = + Constraint.MemberOf + { + target = "some_rel"; + binding = + Constraint.BindingMap.singleton "left" (Constraint.Var "x"); + } + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"x_only" ~relation_name:"xy" ~body:c_on_x + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match Manipulation.Memory.get_relation db ~name:"xy" with + | None -> assert false + | Some r -> r + in + (* Project to only "x", constraint should survive *) + (match Algebra.Memory.project storage [ "x" ] rel with | Error _ -> assert false - | Ok x -> x - in - (* Constraint on x only *) - let c_on_x = - Constraint.MemberOf - { - target = "some_rel"; - binding = - Constraint.BindingMap.singleton "left" (Constraint.Var "x"); - } - in - let db = - match - Manipulation.Memory.register_constraint storage db - ~constraint_name:"x_only" ~relation_name:"xy" ~body:c_on_x - with + | Ok result -> assert (result.Relation.constraints <> None)); + (* Project to only "y", constraint referencing "x" should be dropped *) + match Algebra.Memory.project storage [ "y" ] rel with | Error _ -> assert false - | Ok db -> db - in - let rel = - match Manipulation.Memory.get_relation db ~name:"xy" with - | None -> assert false - | Some r -> r - in - (* Project to only "x", constraint should survive *) - (match Algebra.Memory.project storage [ "x" ] rel with - | Error _ -> assert false - | Ok result -> assert (result.Relation.constraints <> None)); - (* Project to only "y", constraint referencing "x" should be dropped *) - match Algebra.Memory.project storage [ "y" ] rel with - | Error _ -> assert false - | Ok result -> assert (result.Relation.constraints = None)) + | Ok result -> assert (result.Relation.constraints = None)) (* Parse tests use canonical flat sexp format: (Constructor (field val) ...) *) @@ -2355,37 +2684,46 @@ let%test_unit "ddl: parse ClearRelation" = | Ok stmt -> assert (stmt = Ddl.Ast.ClearRelation "users") let%test_unit "dml: round-trip InsertTuple" = - let src = Dml.Ast.InsertTuple { - relation = "users"; - attributes = [("name", Drl.Ast.Str "Alice"); ("age", Drl.Ast.Int 30)] - } in + let src = + Dml.Ast.InsertTuple + { + relation = "users"; + attributes = [ ("name", Drl.Ast.Str "Alice"); ("age", Drl.Ast.Int 30) ]; + } + in match Dml.Parser.of_string (Dml.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) let%test_unit "ddl: round-trip CreateRelation" = - let src = Ddl.Ast.CreateRelation { - name = "users"; - schema = [("name", "string"); ("age", "natural")] - } in + let src = + Ddl.Ast.CreateRelation + { name = "users"; schema = [ ("name", "string"); ("age", "natural") ] } + in match Ddl.Parser.of_string (Ddl.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) let%test_unit "dml: round-trip InsertTuples" = - let src = Dml.Ast.InsertTuples { - relation = "users"; - tuples = [ - [("name", Drl.Ast.Str "Alice"); ("age", Drl.Ast.Int 30)]; - [("name", Drl.Ast.Str "Bob"); ("age", Drl.Ast.Int 25)]; - ] - } in + let src = + Dml.Ast.InsertTuples + { + relation = "users"; + tuples = + [ + [ ("name", Drl.Ast.Str "Alice"); ("age", Drl.Ast.Int 30) ]; + [ ("name", Drl.Ast.Str "Bob"); ("age", Drl.Ast.Int 25) ]; + ]; + } + in match Dml.Parser.of_string (Dml.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) let%test_unit "ddl: round-trip RegisterDomain" = - let src = Ddl.Ast.RegisterDomain { name = "money"; cardinality = Ddl.Ast.AlephZero } in + let src = + Ddl.Ast.RegisterDomain { name = "money"; cardinality = Ddl.Ast.AlephZero } + in match Ddl.Parser.of_string (Ddl.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) @@ -2394,550 +2732,867 @@ let%test_unit "ddl: round-trip RegisterDomain" = let%test_unit "ddl: execute CreateDatabase" = with_storage (fun storage -> - let db = Management.Database.empty ~name:"" in - let stmt = Ddl.Ast.CreateDatabase "shop" in - match Ddl.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok (db, _msg) -> assert (db.name = "shop")) + let db = Management.Database.empty ~name:"" in + let stmt = Ddl.Ast.CreateDatabase "shop" in + match Ddl.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok (db, _msg) -> assert (db.name = "shop")) let%test_unit "ddl: execute CreateRelation" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let stmt = Ddl.Ast.CreateRelation { name = "users"; schema = [("name", "string"); ("age", "natural")] } in - match Ddl.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok (db, _msg) -> assert (Management.Database.has_relation db "users")) + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let stmt = + Ddl.Ast.CreateRelation + { + name = "users"; + schema = [ ("name", "string"); ("age", "natural") ]; + } + in + match Ddl.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok (db, _msg) -> assert (Management.Database.has_relation db "users")) let%test_unit "dml: execute InsertTuple" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "name" "string" in - let db = match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let stmt = Dml.Ast.InsertTuple { relation = "users"; attributes = [("name", Drl.Ast.Str "Alice")] } in - match Dml.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok db -> - let rel = match Management.Database.get_relation db "users" with - | None -> assert false | Some r -> r + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "name" "string" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db in - assert (Manipulation.Memory.tuple_count rel = 1)) + let stmt = + Dml.Ast.InsertTuple + { relation = "users"; attributes = [ ("name", Drl.Ast.Str "Alice") ] } + in + match Dml.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok db -> + let rel = + match Management.Database.get_relation db "users" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count rel = 1)) let%test_unit "dml: execute InsertTuples" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "name" "string" in - let db = match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let stmt = Dml.Ast.InsertTuples { - relation = "users"; - tuples = [[("name", Drl.Ast.Str "Alice")]; [("name", Drl.Ast.Str "Bob")]] - } in - match Dml.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok db -> - let rel = match Management.Database.get_relation db "users" with - | None -> assert false | Some r -> r + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "name" "string" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let stmt = + Dml.Ast.InsertTuples + { + relation = "users"; + tuples = + [ + [ ("name", Drl.Ast.Str "Alice") ]; + [ ("name", Drl.Ast.Str "Bob") ]; + ]; + } in - assert (Manipulation.Memory.tuple_count rel = 2)) + match Dml.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok db -> + let rel = + match Management.Database.get_relation db "users" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count rel = 2)) let%test_unit "dml: execute DeleteTuple" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "name" "string" in - let db = match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "users"; attributes = [("name", Drl.Ast.Str "Alice")] }) with - | Error _ -> assert false | Ok db -> db - in - let stmt = Dml.Ast.DeleteTuple { relation = "users"; attributes = [("name", Drl.Ast.Str "Alice")] } in - match Dml.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok db -> - let rel = match Management.Database.get_relation db "users" with - | None -> assert false | Some r -> r + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "name" "string" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "users"; + attributes = [ ("name", Drl.Ast.Str "Alice") ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let stmt = + Dml.Ast.DeleteTuple + { relation = "users"; attributes = [ ("name", Drl.Ast.Str "Alice") ] } in - assert (Manipulation.Memory.tuple_count rel = 0)) + match Dml.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok db -> + let rel = + match Management.Database.get_relation db "users" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count rel = 0)) let%test_unit "ddl: execute RetractRelation" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty in - let db = match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - match Ddl.Executor.Memory.execute storage db (Ddl.Ast.RetractRelation "users") with - | Error _ -> assert false - | Ok (db, _msg) -> assert (not (Management.Database.has_relation db "users"))) + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + match + Ddl.Executor.Memory.execute storage db (Ddl.Ast.RetractRelation "users") + with + | Error _ -> assert false + | Ok (db, _msg) -> + assert (not (Management.Database.has_relation db "users"))) let%test_unit "ddl: execute ClearRelation" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "name" "string" in - let db = match Manipulation.Memory.create_relation storage db ~name:"users" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuples { relation = "users"; - tuples = [[("name", Drl.Ast.Str "Alice")]; [("name", Drl.Ast.Str "Bob")]] }) with - | Error _ -> assert false | Ok db -> db - in - match Ddl.Executor.Memory.execute storage db (Ddl.Ast.ClearRelation "users") with - | Error _ -> assert false - | Ok (db, _msg) -> - let rel = match Management.Database.get_relation db "users" with - | None -> assert false | Some r -> r + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "name" "string" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"users" ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuples + { + relation = "users"; + tuples = + [ + [ ("name", Drl.Ast.Str "Alice") ]; + [ ("name", Drl.Ast.Str "Bob") ]; + ]; + }) + with + | Error _ -> assert false + | Ok db -> db in - assert (Manipulation.Memory.tuple_count rel = 0)) + match + Ddl.Executor.Memory.execute storage db (Ddl.Ast.ClearRelation "users") + with + | Error _ -> assert false + | Ok (db, _msg) -> + let rel = + match Management.Database.get_relation db "users" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count rel = 0)) let%test_unit "ddl: execute RegisterDomain" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let stmt = Ddl.Ast.RegisterDomain { name = "money"; cardinality = Ddl.Ast.AlephZero } in - match Ddl.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok (db, _msg) -> assert (Management.Database.has_domain db "money")) + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let stmt = + Ddl.Ast.RegisterDomain + { name = "money"; cardinality = Ddl.Ast.AlephZero } + in + match Ddl.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok (db, _msg) -> assert (Management.Database.has_domain db "money")) let%test_unit "dml: insert into nonexistent relation returns error" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let stmt = Dml.Ast.InsertTuple { relation = "ghost"; attributes = [("x", Drl.Ast.Int 1)] } in - match Dml.Executor.Memory.execute storage db stmt with - | Error (Dml.Executor.Memory.RelationNotFound "ghost") -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let stmt = + Dml.Ast.InsertTuple + { relation = "ghost"; attributes = [ ("x", Drl.Ast.Int 1) ] } + in + match Dml.Executor.Memory.execute storage db stmt with + | Error (Dml.Executor.Memory.RelationNotFound "ghost") -> () + | _ -> assert false) let%test_unit "dcl: round-trip RegisterConstraint MemberOf" = - let src = Icl.Ast.RegisterConstraint { - constraint_name = "fk_order"; - relation_name = "order_items"; - body = Icl.Ast.MemberOf { target = "orders"; binding = [("order_id", Icl.Ast.Var "order_id")] } - } in + let src = + Icl.Ast.RegisterConstraint + { + constraint_name = "fk_order"; + relation_name = "order_items"; + body = + Icl.Ast.MemberOf + { + target = "orders"; + binding = [ ("order_id", Icl.Ast.Var "order_id") ]; + }; + } + in match Icl.Parser.of_string (Icl.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) let%test_unit "dcl: round-trip And constraint" = - let src = Icl.Ast.RegisterConstraint { - constraint_name = "valid_range"; - relation_name = "scores"; - body = Icl.Ast.And [ - Icl.Ast.MemberOf { target = "ge_zero"; - binding = [("left", Icl.Ast.Var "score"); ("right", Icl.Ast.Const (Drl.Ast.Int 0))] }; - Icl.Ast.MemberOf { target = "le_hundred"; - binding = [("left", Icl.Ast.Var "score"); ("right", Icl.Ast.Const (Drl.Ast.Int 100))] }; - ] - } in + let src = + Icl.Ast.RegisterConstraint + { + constraint_name = "valid_range"; + relation_name = "scores"; + body = + Icl.Ast.And + [ + Icl.Ast.MemberOf + { + target = "ge_zero"; + binding = + [ + ("left", Icl.Ast.Var "score"); + ("right", Icl.Ast.Const (Drl.Ast.Int 0)); + ]; + }; + Icl.Ast.MemberOf + { + target = "le_hundred"; + binding = + [ + ("left", Icl.Ast.Var "score"); + ("right", Icl.Ast.Const (Drl.Ast.Int 100)); + ]; + }; + ]; + } + in match Icl.Parser.of_string (Icl.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) let%test_unit "dcl: round-trip Not constraint" = - let src = Icl.Ast.RegisterConstraint { - constraint_name = "not_closed"; - relation_name = "open_ticket"; - body = Icl.Ast.Not { - body = Icl.Ast.MemberOf { target = "closed_ticket"; - binding = [("ticket_id", Icl.Ast.Var "ticket_id")] }; - universe = "open_ticket" - } - } in + let src = + Icl.Ast.RegisterConstraint + { + constraint_name = "not_closed"; + relation_name = "open_ticket"; + body = + Icl.Ast.Not + { + body = + Icl.Ast.MemberOf + { + target = "closed_ticket"; + binding = [ ("ticket_id", Icl.Ast.Var "ticket_id") ]; + }; + universe = "open_ticket"; + }; + } + in match Icl.Parser.of_string (Icl.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) let%test_unit "dcl: execute RegisterConstraint attaches constraint" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "order_id" "natural" in - let db = match Manipulation.Memory.create_relation storage db ~name:"order_items" ~schema with - | Error _ -> assert false | Ok (db, _) -> db - in - let stmt = Icl.Ast.RegisterConstraint { - constraint_name = "fk_order"; - relation_name = "order_items"; - body = Icl.Ast.MemberOf { target = "orders"; binding = [("order_id", Icl.Ast.Var "order_id")] } - } in - match Icl.Executor.Memory.execute storage db stmt with - | Error _ -> assert false - | Ok (db, _) -> - let rel = match Management.Database.get_relation db "order_items" with - | None -> assert false | Some r -> r + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db in - assert (rel.Relation.constraints <> None)) + let schema = Schema.empty |> Schema.add "order_id" "natural" in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"order_items" + ~schema + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let stmt = + Icl.Ast.RegisterConstraint + { + constraint_name = "fk_order"; + relation_name = "order_items"; + body = + Icl.Ast.MemberOf + { + target = "orders"; + binding = [ ("order_id", Icl.Ast.Var "order_id") ]; + }; + } + in + match Icl.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok (db, _) -> + let rel = + match Management.Database.get_relation db "order_items" with + | None -> assert false + | Some r -> r + in + assert (rel.Relation.constraints <> None)) let%test_unit "dcl: FK constraint enforced on insert" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"shop" with - | Error _ -> assert false | Ok db -> db - in - let db = match Manipulation.Memory.create_relation storage db ~name:"orders" - ~schema:(Schema.empty |> Schema.add "id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db - in - (* Insert a valid order *) - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "orders"; attributes = [("id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Manipulation.Memory.create_relation storage db ~name:"order_items" - ~schema:(Schema.empty |> Schema.add "order_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db - in - (* Register FK: order_id in order_items must match id in orders *) - let db = match Icl.Executor.Memory.execute storage db - (Icl.Ast.RegisterConstraint { - constraint_name = "fk_order"; - relation_name = "order_items"; - body = Icl.Ast.MemberOf { target = "orders"; binding = [("id", Icl.Ast.Var "order_id")] } - }) with - | Error _ -> assert false | Ok (db, _) -> db - in - (* Valid insert: order_id=1 exists in orders *) - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "order_items"; attributes = [("order_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let rel = match Management.Database.get_relation db "order_items" with - | None -> assert false | Some r -> r - in - assert (Manipulation.Memory.tuple_count rel = 1); - (* Invalid insert: order_id=99 does not exist in orders *) - match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "order_items"; attributes = [("order_id", Drl.Ast.Int 99)] }) with - | Error (Dml.Executor.Memory.ManipulationError (Manipulation.ConstraintViolation _)) -> () - | _ -> assert false) + let db = + match Manipulation.Memory.create_database storage ~name:"shop" with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"orders" + ~schema:(Schema.empty |> Schema.add "id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db + in + (* Insert a valid order *) + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { relation = "orders"; attributes = [ ("id", Drl.Ast.Int 1) ] }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"order_items" + ~schema:(Schema.empty |> Schema.add "order_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db + in + (* Register FK: order_id in order_items must match id in orders *) + let db = + match + Icl.Executor.Memory.execute storage db + (Icl.Ast.RegisterConstraint + { + constraint_name = "fk_order"; + relation_name = "order_items"; + body = + Icl.Ast.MemberOf + { + target = "orders"; + binding = [ ("id", Icl.Ast.Var "order_id") ]; + }; + }) + with + | Error _ -> assert false + | Ok (db, _) -> db + in + (* Valid insert: order_id=1 exists in orders *) + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "order_items"; + attributes = [ ("order_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let rel = + match Management.Database.get_relation db "order_items" with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count rel = 1); + (* Invalid insert: order_id=99 does not exist in orders *) + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "order_items"; + attributes = [ ("order_id", Drl.Ast.Int 99) ]; + }) + with + | Error + (Dml.Executor.Memory.ManipulationError + (Manipulation.ConstraintViolation _)) -> + () + | _ -> assert false) -module BranchMemory = Management.Branch.Make(Management.Physical.Memory) +module BranchMemory = Management.Branch.Make (Management.Physical.Memory) let%test_unit "branch: create and get_tip" = with_storage (fun storage -> - let tip = "deadbeef" in - (match BranchMemory.create storage ~name:"main" ~tip with - | Error _ -> assert false - | Ok () -> ()); - match BranchMemory.get_tip storage "main" with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some t) -> assert (t = tip)) + let tip = "deadbeef" in + (match BranchMemory.create storage ~name:"main" ~tip with + | Error _ -> assert false + | Ok () -> ()); + match BranchMemory.get_tip storage "main" with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some t) -> assert (t = tip)) let%test_unit "branch: get_tip returns None for unknown branch" = with_storage (fun storage -> - match BranchMemory.get_tip storage "nonexistent" with - | Error _ -> assert false - | Ok None -> () - | Ok (Some _) -> assert false) + match BranchMemory.get_tip storage "nonexistent" with + | Error _ -> assert false + | Ok None -> () + | Ok (Some _) -> assert false) let%test_unit "branch: checkout and get_head" = with_storage (fun storage -> - (match BranchMemory.create storage ~name:"main" ~tip:"abc" with - | Error _ -> assert false | Ok () -> ()); - (match BranchMemory.checkout storage "main" with - | Error _ -> assert false | Ok () -> ()); - match BranchMemory.get_head storage with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some h) -> assert (h = "main")) + (match BranchMemory.create storage ~name:"main" ~tip:"abc" with + | Error _ -> assert false + | Ok () -> ()); + (match BranchMemory.checkout storage "main" with + | Error _ -> assert false + | Ok () -> ()); + match BranchMemory.get_head storage with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some h) -> assert (h = "main")) let%test_unit "branch: get_head returns None when not set" = with_storage (fun storage -> - match BranchMemory.get_head storage with - | Error _ -> assert false - | Ok None -> () - | Ok (Some _) -> assert false) + match BranchMemory.get_head storage with + | Error _ -> assert false + | Ok None -> () + | Ok (Some _) -> assert false) let%test_unit "branch: update_tip advances the branch" = with_storage (fun storage -> - (match BranchMemory.create storage ~name:"main" ~tip:"v1" with - | Error _ -> assert false | Ok () -> ()); - (match BranchMemory.update_tip storage ~name:"main" ~tip:"v2" with - | Error _ -> assert false | Ok () -> ()); - match BranchMemory.get_tip storage "main" with - | Error _ -> assert false - | Ok None -> assert false - | Ok (Some t) -> assert (t = "v2")) + (match BranchMemory.create storage ~name:"main" ~tip:"v1" with + | Error _ -> assert false + | Ok () -> ()); + (match BranchMemory.update_tip storage ~name:"main" ~tip:"v2" with + | Error _ -> assert false + | Ok () -> ()); + match BranchMemory.get_tip storage "main" with + | Error _ -> assert false + | Ok None -> assert false + | Ok (Some t) -> assert (t = "v2")) let%test_unit "branch: update_tip fails on unknown branch" = with_storage (fun storage -> - match BranchMemory.update_tip storage ~name:"ghost" ~tip:"v1" with - | Error _ -> () - | Ok () -> assert false) + match BranchMemory.update_tip storage ~name:"ghost" ~tip:"v1" with + | Error _ -> () + | Ok () -> assert false) let%test_unit "branch: multiple branches are independent" = with_storage (fun storage -> - (match BranchMemory.create storage ~name:"main" ~tip:"hash-main" with - | Error _ -> assert false | Ok () -> ()); - (match BranchMemory.create storage ~name:"feature" ~tip:"hash-feature" with - | Error _ -> assert false | Ok () -> ()); - let main_tip = match BranchMemory.get_tip storage "main" with - | Ok (Some t) -> t | _ -> assert false - in - let feat_tip = match BranchMemory.get_tip storage "feature" with - | Ok (Some t) -> t | _ -> assert false - in - assert (main_tip = "hash-main"); - assert (feat_tip = "hash-feature"); - assert (main_tip <> feat_tip)) + (match BranchMemory.create storage ~name:"main" ~tip:"hash-main" with + | Error _ -> assert false + | Ok () -> ()); + (match + BranchMemory.create storage ~name:"feature" ~tip:"hash-feature" + with + | Error _ -> assert false + | Ok () -> ()); + let main_tip = + match BranchMemory.get_tip storage "main" with + | Ok (Some t) -> t + | _ -> assert false + in + let feat_tip = + match BranchMemory.get_tip storage "feature" with + | Ok (Some t) -> t + | _ -> assert false + in + assert (main_tip = "hash-main"); + assert (feat_tip = "hash-feature"); + assert (main_tip <> feat_tip)) let%test_unit "diff: identical databases produce empty diff" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - let diffs = Management.Diff.diff ~ancestor:db ~target:db in - assert (diffs = [])) + let db = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + let diffs = Management.Diff.diff ~ancestor:db ~target:db in + assert (diffs = [])) let%test_unit "diff: added relation detected" = with_storage (fun storage -> - let ancestor = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - let schema = Schema.empty |> Schema.add "x" "natural" in - let target, _ = match Manipulation.Memory.create_relation storage ancestor - ~name:"new_rel" ~schema with - | Error _ -> assert false | Ok p -> p - in - let diffs = Management.Diff.diff ~ancestor ~target in - let added = List.filter_map (function - | Management.Diff.RelationAdded r -> Some r - | _ -> None) diffs - in - assert (List.exists (fun r -> r.Relation.name = "new_rel") added)) + let ancestor = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + let schema = Schema.empty |> Schema.add "x" "natural" in + let target, _ = + match + Manipulation.Memory.create_relation storage ancestor ~name:"new_rel" + ~schema + with + | Error _ -> assert false + | Ok p -> p + in + let diffs = Management.Diff.diff ~ancestor ~target in + let added = + List.filter_map + (function Management.Diff.RelationAdded r -> Some r | _ -> None) + diffs + in + assert (List.exists (fun r -> r.Relation.name = "new_rel") added)) let%test_unit "diff: removed relation detected" = with_storage (fun storage -> - let schema = Schema.empty |> Schema.add "x" "natural" in - let ancestor = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - let ancestor, _ = match Manipulation.Memory.create_relation storage ancestor - ~name:"gone" ~schema with - | Error _ -> assert false | Ok p -> p - in - let target = match Manipulation.Memory.retract_relation storage ancestor ~name:"gone" with - | Error _ -> assert false | Ok db -> db - in - let diffs = Management.Diff.diff ~ancestor ~target in - let removed = List.filter_map (function - | Management.Diff.RelationRemoved n -> Some n - | _ -> None) diffs - in - assert (List.mem "gone" removed)) + let schema = Schema.empty |> Schema.add "x" "natural" in + let ancestor = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + let ancestor, _ = + match + Manipulation.Memory.create_relation storage ancestor ~name:"gone" + ~schema + with + | Error _ -> assert false + | Ok p -> p + in + let target = + match + Manipulation.Memory.retract_relation storage ancestor ~name:"gone" + with + | Error _ -> assert false + | Ok db -> db + in + let diffs = Management.Diff.diff ~ancestor ~target in + let removed = + List.filter_map + (function Management.Diff.RelationRemoved n -> Some n | _ -> None) + diffs + in + assert (List.mem "gone" removed)) let%test_unit "diff: modified relation detected with added tuple" = with_storage (fun storage -> - let schema = Schema.empty |> Schema.add "val" "natural" in - let ancestor = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - let ancestor, _ = match Manipulation.Memory.create_relation storage ancestor - ~name:"r" ~schema with - | Error _ -> assert false | Ok p -> p - in - let rel = Option.get (Management.Database.get_relation ancestor "r") in - let t : Tuple.materialized = { - Tuple.relation = "r"; - attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 42 }; - } in - let (target, _, _) = match Manipulation.Memory.create_tuple storage ancestor rel t with - | Error _ -> assert false | Ok p -> p - in - let diffs = Management.Diff.diff ~ancestor ~target in - assert (List.length diffs = 1); - match diffs with - | [ Management.Diff.RelationModified { name; added_tuples; removed_tuples; _ } ] -> - assert (name = "r"); - assert (List.length added_tuples = 1); - assert (removed_tuples = []) - | _ -> assert false) - -module MergeMemory = Management.Merge.Make - (Management.Physical.Memory) - (Manipulation.Memory) + let schema = Schema.empty |> Schema.add "val" "natural" in + let ancestor = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + let ancestor, _ = + match + Manipulation.Memory.create_relation storage ancestor ~name:"r" ~schema + with + | Error _ -> assert false + | Ok p -> p + in + let rel = Option.get (Management.Database.get_relation ancestor "r") in + let t : Tuple.materialized = + { + Tuple.relation = "r"; + attributes = + Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 42 }; + } + in + let target, _, _ = + match Manipulation.Memory.create_tuple storage ancestor rel t with + | Error _ -> assert false + | Ok p -> p + in + let diffs = Management.Diff.diff ~ancestor ~target in + assert (List.length diffs = 1); + match diffs with + | [ + Management.Diff.RelationModified + { name; added_tuples; removed_tuples; _ }; + ] -> + assert (name = "r"); + assert (List.length added_tuples = 1); + assert (removed_tuples = []) + | _ -> assert false) + +module MergeMemory = + Management.Merge.Make (Management.Physical.Memory) (Manipulation.Memory) let%test_unit "merge: fast-forward when only one side changed" = with_storage (fun storage -> - let schema = Schema.empty |> Schema.add "val" "natural" in - let base_db = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - let base_db, _ = match Manipulation.Memory.create_relation storage base_db - ~name:"r" ~schema with - | Error _ -> assert false | Ok p -> p - in - (match Manipulation.Memory.store_database storage base_db with - | Error _ -> assert false | Ok () -> ()); - let rel = Option.get (Management.Database.get_relation base_db "r") in - let t1 : Tuple.materialized = { - Tuple.relation = "r"; - attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 1 }; - } in - let (left_db, _, _) = match Manipulation.Memory.create_tuple storage base_db rel t1 with - | Error _ -> assert false | Ok p -> p - in - (match Manipulation.Memory.store_database storage left_db with - | Error _ -> assert false | Ok () -> ()); - match MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft - ~left_tip:left_db.Management.Database.hash - ~right_tip:base_db.Management.Database.hash with - | Error _ -> assert false - | Ok (Management.Merge.Failed _) -> assert false - | Ok (Management.Merge.Clean merged) -> - let merged_rel = Option.get (Management.Database.get_relation merged "r") in - assert (Manipulation.Memory.tuple_count merged_rel = 1)) + let schema = Schema.empty |> Schema.add "val" "natural" in + let base_db = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + let base_db, _ = + match + Manipulation.Memory.create_relation storage base_db ~name:"r" ~schema + with + | Error _ -> assert false + | Ok p -> p + in + (match Manipulation.Memory.store_database storage base_db with + | Error _ -> assert false + | Ok () -> ()); + let rel = Option.get (Management.Database.get_relation base_db "r") in + let t1 : Tuple.materialized = + { + Tuple.relation = "r"; + attributes = + Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 1 }; + } + in + let left_db, _, _ = + match Manipulation.Memory.create_tuple storage base_db rel t1 with + | Error _ -> assert false + | Ok p -> p + in + (match Manipulation.Memory.store_database storage left_db with + | Error _ -> assert false + | Ok () -> ()); + match + MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft + ~left_tip:left_db.Management.Database.hash + ~right_tip:base_db.Management.Database.hash + with + | Error _ -> assert false + | Ok (Management.Merge.Failed _) -> assert false + | Ok (Management.Merge.Clean merged) -> + let merged_rel = + Option.get (Management.Database.get_relation merged "r") + in + assert (Manipulation.Memory.tuple_count merged_rel = 1)) let%test_unit "merge: independent tuple additions produce union" = with_storage (fun storage -> - let schema = Schema.empty |> Schema.add "val" "natural" in - let base_db = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - let base_db, _ = match Manipulation.Memory.create_relation storage base_db - ~name:"r" ~schema with - | Error _ -> assert false | Ok p -> p - in - (match Manipulation.Memory.store_database storage base_db with - | Error _ -> assert false | Ok () -> ()); - let rel = Option.get (Management.Database.get_relation base_db "r") in - let t_left : Tuple.materialized = { - Tuple.relation = "r"; - attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 10 }; - } in - let (left_db, _, _) = match Manipulation.Memory.create_tuple storage base_db rel t_left with - | Error _ -> assert false | Ok p -> p - in - (match Manipulation.Memory.store_database storage left_db with - | Error _ -> assert false | Ok () -> ()); - let t_right : Tuple.materialized = { - Tuple.relation = "r"; - attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 20 }; - } in - let (right_db, _, _) = match Manipulation.Memory.create_tuple storage base_db rel t_right with - | Error _ -> assert false | Ok p -> p - in - (match Manipulation.Memory.store_database storage right_db with - | Error _ -> assert false | Ok () -> ()); - match MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft - ~left_tip:left_db.Management.Database.hash - ~right_tip:right_db.Management.Database.hash with - | Error _ -> assert false - | Ok (Management.Merge.Failed _) -> assert false - | Ok (Management.Merge.Clean merged) -> - let merged_rel = Option.get (Management.Database.get_relation merged "r") in - assert (Manipulation.Memory.tuple_count merged_rel = 2)) + let schema = Schema.empty |> Schema.add "val" "natural" in + let base_db = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + let base_db, _ = + match + Manipulation.Memory.create_relation storage base_db ~name:"r" ~schema + with + | Error _ -> assert false + | Ok p -> p + in + (match Manipulation.Memory.store_database storage base_db with + | Error _ -> assert false + | Ok () -> ()); + let rel = Option.get (Management.Database.get_relation base_db "r") in + let t_left : Tuple.materialized = + { + Tuple.relation = "r"; + attributes = + Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 10 }; + } + in + let left_db, _, _ = + match Manipulation.Memory.create_tuple storage base_db rel t_left with + | Error _ -> assert false + | Ok p -> p + in + (match Manipulation.Memory.store_database storage left_db with + | Error _ -> assert false + | Ok () -> ()); + let t_right : Tuple.materialized = + { + Tuple.relation = "r"; + attributes = + Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 20 }; + } + in + let right_db, _, _ = + match Manipulation.Memory.create_tuple storage base_db rel t_right with + | Error _ -> assert false + | Ok p -> p + in + (match Manipulation.Memory.store_database storage right_db with + | Error _ -> assert false + | Ok () -> ()); + match + MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft + ~left_tip:left_db.Management.Database.hash + ~right_tip:right_db.Management.Database.hash + with + | Error _ -> assert false + | Ok (Management.Merge.Failed _) -> assert false + | Ok (Management.Merge.Clean merged) -> + let merged_rel = + Option.get (Management.Database.get_relation merged "r") + in + assert (Manipulation.Memory.tuple_count merged_rel = 2)) let%test_unit "merge: no-op when both sides are identical" = with_storage (fun storage -> - let base_db = match Manipulation.Memory.create_database storage ~name:"db" with - | Error _ -> assert false | Ok db -> db - in - (match Manipulation.Memory.store_database storage base_db with - | Error _ -> assert false | Ok () -> ()); - match MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft - ~left_tip:base_db.Management.Database.hash - ~right_tip:base_db.Management.Database.hash with - | Error _ -> assert false - | Ok (Management.Merge.Failed _) -> assert false - | Ok (Management.Merge.Clean merged) -> - assert (Management.Database.get_relation_names merged = - Management.Database.get_relation_names base_db)) + let base_db = + match Manipulation.Memory.create_database storage ~name:"db" with + | Error _ -> assert false + | Ok db -> db + in + (match Manipulation.Memory.store_database storage base_db with + | Error _ -> assert false + | Ok () -> ()); + match + MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft + ~left_tip:base_db.Management.Database.hash + ~right_tip:base_db.Management.Database.hash + with + | Error _ -> assert false + | Ok (Management.Merge.Failed _) -> assert false + | Ok (Management.Merge.Clean merged) -> + assert ( + Management.Database.get_relation_names merged + = Management.Database.get_relation_names base_db)) (* Helper: look up polarity for a relation name in the result map *) -let find_polarity name pols = - Constraint.PolarityMap.find_opt name pols +let find_polarity name pols = Constraint.PolarityMap.find_opt name pols let%test_unit "polarity: MemberOf target is Positive" = - let c = Constraint.MemberOf { - target = "R"; - binding = Constraint.BindingMap.empty; - } in - assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Positive) + let c = + Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty } + in + assert ( + find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Positive) let%test_unit "polarity: Not MemberOf flips to Negative" = - let c = Constraint.Not { - body = Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty }; - universe = "U"; - } in - assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Negative) + let c = + Constraint.Not + { + body = + Constraint.MemberOf + { target = "R"; binding = Constraint.BindingMap.empty }; + universe = "U"; + } + in + assert ( + find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Negative) let%test_unit "polarity: Exists quantifier is Positive" = - let c = Constraint.Exists { - variable = "x"; - quantifier = "Q"; - body = Constraint.MemberOf { target = "Q"; binding = Constraint.BindingMap.empty }; - } in - assert (find_polarity "Q" (Constraint.polarity_of c) = Some Constraint.Positive) + let c = + Constraint.Exists + { + variable = "x"; + quantifier = "Q"; + body = + Constraint.MemberOf + { target = "Q"; binding = Constraint.BindingMap.empty }; + } + in + assert ( + find_polarity "Q" (Constraint.polarity_of c) = Some Constraint.Positive) let%test_unit "polarity: Forall quantifier is Negative" = - let c = Constraint.Forall { - variable = "x"; - quantifier = "Q"; - body = Constraint.MemberOf { target = "T"; binding = Constraint.BindingMap.empty }; - } in - assert (find_polarity "Q" (Constraint.polarity_of c) = Some Constraint.Negative); - assert (find_polarity "T" (Constraint.polarity_of c) = Some Constraint.Positive) + let c = + Constraint.Forall + { + variable = "x"; + quantifier = "Q"; + body = + Constraint.MemberOf + { target = "T"; binding = Constraint.BindingMap.empty }; + } + in + assert ( + find_polarity "Q" (Constraint.polarity_of c) = Some Constraint.Negative); + assert ( + find_polarity "T" (Constraint.polarity_of c) = Some Constraint.Positive) let%test_unit "polarity: same relation with both polarities merges to Both" = (* Not(MemberOf R) AND MemberOf R => R appears Negative and Positive => Both *) - let c = Constraint.And [ - Constraint.Not { - body = Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty }; - universe = "U"; - }; - Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty }; - ] in + let c = + Constraint.And + [ + Constraint.Not + { + body = + Constraint.MemberOf + { target = "R"; binding = Constraint.BindingMap.empty }; + universe = "U"; + }; + Constraint.MemberOf + { target = "R"; binding = Constraint.BindingMap.empty }; + ] + in assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Both) let%test_unit "polarity: Forall body MemberOf keeps Positive" = (* Forall x in Q, MemberOf(T): T still has positive polarity *) - let c = Constraint.Forall { - variable = "x"; - quantifier = "Q"; - body = Constraint.MemberOf { target = "T"; binding = Constraint.BindingMap.empty }; - } in - assert (find_polarity "T" (Constraint.polarity_of c) = Some Constraint.Positive) + let c = + Constraint.Forall + { + variable = "x"; + quantifier = "Q"; + body = + Constraint.MemberOf + { target = "T"; binding = Constraint.BindingMap.empty }; + } + in + assert ( + find_polarity "T" (Constraint.polarity_of c) = Some Constraint.Positive) let%test_unit "polarity: nested Not double-negation restores Positive" = - let c = Constraint.Not { - body = Constraint.Not { - body = Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty }; - universe = "U"; - }; - universe = "V"; - } in - assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Positive) + let c = + Constraint.Not + { + body = + Constraint.Not + { + body = + Constraint.MemberOf + { target = "R"; binding = Constraint.BindingMap.empty }; + universe = "U"; + }; + universe = "V"; + } + in + assert ( + find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Positive) let%test_unit "polarity: unrelated relation absent from result" = - let c = Constraint.MemberOf { - target = "R"; - binding = Constraint.BindingMap.empty; - } in + let c = + Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty } + in assert (find_polarity "S" (Constraint.polarity_of c) = None) -let abs i = Obj.magic (i : int) (* lift int to AbstractValue for tests *) +let abs i = Obj.magic (i : int) (* lift int to AbstractValue for tests *) -let%test_unit "focused_filter: Var binding maps deleted value to constrained attr" = +let%test_unit + "focused_filter: Var binding maps deleted value to constrained attr" = (* Constraint: MemberOf Dept (dept_id = Var "dept_id") Deleted: Dept { dept_id = 99 } Expected filter: [("dept_id", 99)] @@ -2953,11 +3608,11 @@ let%test_unit "focused_filter: Var binding maps deleted value to constrained att Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id") in let c = Constraint.MemberOf { target = "Dept"; binding } in - let deleted = [("dept_id", abs 99)] in + let deleted = [ ("dept_id", abs 99) ] in let filter = Constraint.focused_filter c "Dept" deleted in assert (List.length filter = 1); assert (fst (List.hd filter) = "dept_id"); - assert (Stdlib.(=) (snd (List.hd filter)) (abs 99)) + assert (Stdlib.( = ) (snd (List.hd filter)) (abs 99)) let%test_unit "focused_filter: Const binding is ignored (no var link)" = (* Constraint: MemberOf Dept (code = Const "eng") @@ -2979,7 +3634,9 @@ let%test_unit "focused_filter: Const binding is ignored (no var link)" = (Constraint.Const (Obj.magic ("eng" : string))) in let c = Constraint.MemberOf { target = "Dept"; binding } in - let filter = Constraint.focused_filter c "Dept" [("code", Obj.magic ("eng" : string))] in + let filter = + Constraint.focused_filter c "Dept" [ ("code", Obj.magic ("eng" : string)) ] + in assert (filter = []) let%test_unit "focused_filter: Exists body MemberOf same relation is followed" = @@ -2998,12 +3655,15 @@ let%test_unit "focused_filter: Exists body MemberOf same relation is followed" = let binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id") in - let c = Constraint.Exists { - variable = "d"; - quantifier = "Dept"; - body = Constraint.MemberOf { target = "Dept"; binding }; - } in - let filter = Constraint.focused_filter c "Dept" [("dept_id", abs 7)] in + let c = + Constraint.Exists + { + variable = "d"; + quantifier = "Dept"; + body = Constraint.MemberOf { target = "Dept"; binding }; + } + in + let filter = Constraint.focused_filter c "Dept" [ ("dept_id", abs 7) ] in assert (List.length filter = 1); assert (fst (List.hd filter) = "dept_id") @@ -3015,11 +3675,9 @@ let%test_unit "focused_filter: unrelated dep_rel yields empty filter" = the deletion cannot possibly affect any constrained tuple since no join variable links them. The cascade checker uses [] as a signal to skip the re-check for this constraint entirely, not to re-check everything. *) - let binding = - Constraint.BindingMap.singleton "x" (Constraint.Var "x") - in + let binding = Constraint.BindingMap.singleton "x" (Constraint.Var "x") in let c = Constraint.MemberOf { target = "R"; binding } in - let filter = Constraint.focused_filter c "S" [("x", abs 1)] in + let filter = Constraint.focused_filter c "S" [ ("x", abs 1) ] in assert (filter = []) let%test_unit "trigger_constants: Const value in binding is extracted" = @@ -3051,9 +3709,7 @@ let%test_unit "trigger_constants: Var binding produces no constant" = It is a join variable, not a filter. Any deleted tuple from R could match a constrained tuple via the Var link, so no early-exit is possible. [] means: always proceed to the cascade scan. *) - let binding = - Constraint.BindingMap.singleton "id" (Constraint.Var "id") - in + let binding = Constraint.BindingMap.singleton "id" (Constraint.Var "id") in let c = Constraint.MemberOf { target = "R"; binding } in let consts = Constraint.trigger_constants c "R" in assert (consts = []) @@ -3074,72 +3730,99 @@ let%test_unit "trigger_constants: unrelated dep_rel yields empty" = let consts = Constraint.trigger_constants c "S" in assert (consts = []) -let%test_unit "substitute_transition: Var \"variable.attr\" is replaced by Const from transition tuple" = +let%test_unit + "substitute_transition: Var \"variable.attr\" is replaced by Const from \ + transition tuple" = (* Constraint: Exists d in Department, MemberOf Target (key = Var "d.dept_id") Transition: Department row { dept_id = 99 } After substitution: Exists d in Department, MemberOf Target (key = Const 99) The namespaced Var "d.dept_id" (quantifier-scoped) is replaced; a base-tuple Var "dept_id" would not be. *) let c = - Constraint.Exists { - variable = "d"; quantifier = "Department"; - body = Constraint.MemberOf { - target = "Target"; - binding = Constraint.BindingMap.singleton "key" (Constraint.Var "d.dept_id"); - }; - } + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = + Constraint.MemberOf + { + target = "Target"; + binding = + Constraint.BindingMap.singleton "key" + (Constraint.Var "d.dept_id"); + }; + } + in + let result = + Constraint.substitute_transition c "Department" [ ("dept_id", abs 99) ] in - let result = Constraint.substitute_transition c "Department" [("dept_id", abs 99)] in - (match result with - | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } -> - (match Constraint.BindingMap.find_opt "key" binding with - | Some (Constraint.Const v) -> assert (Stdlib.(=) v (abs 99)) + match result with + | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } -> ( + match Constraint.BindingMap.find_opt "key" binding with + | Some (Constraint.Const v) -> assert (Stdlib.( = ) v (abs 99)) | _ -> assert false) - | _ -> assert false) + | _ -> assert false let%test_unit "substitute_transition: base-tuple Var is not substituted" = (* Constraint: Exists d in Department, MemberOf Target (key = Var "dept_id") Var "dept_id" is a base-tuple reference (no "d." prefix), so it must survive substitution unchanged. Only "d.dept_id" would be replaced. *) let c = - Constraint.Exists { - variable = "d"; quantifier = "Department"; - body = Constraint.MemberOf { - target = "Target"; - binding = Constraint.BindingMap.singleton "key" (Constraint.Var "dept_id"); - }; - } + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = + Constraint.MemberOf + { + target = "Target"; + binding = + Constraint.BindingMap.singleton "key" (Constraint.Var "dept_id"); + }; + } in - let result = Constraint.substitute_transition c "Department" [("dept_id", abs 99)] in - (match result with - | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } -> - (match Constraint.BindingMap.find_opt "key" binding with + let result = + Constraint.substitute_transition c "Department" [ ("dept_id", abs 99) ] + in + match result with + | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } -> ( + match Constraint.BindingMap.find_opt "key" binding with | Some (Constraint.Var "dept_id") -> () | _ -> assert false) - | _ -> assert false) + | _ -> assert false -let%test_unit "substitute_transition: non-matching quantifier relation is unchanged" = +let%test_unit + "substitute_transition: non-matching quantifier relation is unchanged" = (* Constraint: Exists d in Department, MemberOf Target (key = Var "d.dept_id") Transition is for relation "Other", not "Department". The body must survive unmodified. *) let c = - Constraint.Exists { - variable = "d"; quantifier = "Department"; - body = Constraint.MemberOf { - target = "Target"; - binding = Constraint.BindingMap.singleton "key" (Constraint.Var "d.dept_id"); - }; - } + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = + Constraint.MemberOf + { + target = "Target"; + binding = + Constraint.BindingMap.singleton "key" + (Constraint.Var "d.dept_id"); + }; + } + in + let result = + Constraint.substitute_transition c "Other" [ ("dept_id", abs 99) ] in - let result = Constraint.substitute_transition c "Other" [("dept_id", abs 99)] in - (match result with - | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } -> - (match Constraint.BindingMap.find_opt "key" binding with + match result with + | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } -> ( + match Constraint.BindingMap.find_opt "key" binding with | Some (Constraint.Var "d.dept_id") -> () | _ -> assert false) - | _ -> assert false) + | _ -> assert false -let%test_unit "substitute_transition: substitution applies through And and Not" = +let%test_unit "substitute_transition: substitution applies through And and Not" + = (* Constraint: Exists d in Department, And [ @@ -3149,75 +3832,112 @@ let%test_unit "substitute_transition: substitution applies through And and Not" Transition: { x = 1, y = 2 } After substitution: Var "d.x" -> Const 1, Var "d.y" -> Const 2 *) let c = - Constraint.Exists { - variable = "d"; quantifier = "Department"; - body = Constraint.And [ - Constraint.MemberOf { - target = "A"; - binding = Constraint.BindingMap.singleton "x" (Constraint.Var "d.x"); - }; - Constraint.Not { - universe = "B"; - body = Constraint.MemberOf { - target = "B"; - binding = Constraint.BindingMap.singleton "y" (Constraint.Var "d.y"); - }; - }; - ]; - } + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = + Constraint.And + [ + Constraint.MemberOf + { + target = "A"; + binding = + Constraint.BindingMap.singleton "x" (Constraint.Var "d.x"); + }; + Constraint.Not + { + universe = "B"; + body = + Constraint.MemberOf + { + target = "B"; + binding = + Constraint.BindingMap.singleton "y" + (Constraint.Var "d.y"); + }; + }; + ]; + } + in + let result = + Constraint.substitute_transition c "Department" + [ ("x", abs 1); ("y", abs 2) ] in - let result = Constraint.substitute_transition c "Department" [("x", abs 1); ("y", abs 2)] in - (match result with - | Constraint.Exists { - body = Constraint.And [ - Constraint.MemberOf { binding = b1; _ }; - Constraint.Not { body = Constraint.MemberOf { binding = b2; _ }; _ }; - ]; _ - } -> - (match Constraint.BindingMap.find_opt "x" b1, - Constraint.BindingMap.find_opt "y" b2 with + match result with + | Constraint.Exists + { + body = + Constraint.And + [ + Constraint.MemberOf { binding = b1; _ }; + Constraint.Not + { body = Constraint.MemberOf { binding = b2; _ }; _ }; + ]; + _; + } -> ( + match + ( Constraint.BindingMap.find_opt "x" b1, + Constraint.BindingMap.find_opt "y" b2 ) + with | Some (Constraint.Const v1), Some (Constraint.Const v2) -> - assert (Stdlib.(=) v1 (abs 1)); - assert (Stdlib.(=) v2 (abs 2)) + assert (Stdlib.( = ) v1 (abs 1)); + assert (Stdlib.( = ) v2 (abs 2)) | _ -> assert false) - | _ -> assert false) + | _ -> assert false (* Build a minimal db with two relations and an FK constraint: Department { dept_id } <-- Employee { emp_id, dept_id } Constraint on Employee: Exists d in Department, MemberOf Department (dept_id = Var "dept_id") *) let setup_fk_db storage = - let db = match Manipulation.Memory.create_database storage ~name:"hr" with - | Error _ -> assert false | Ok db -> db + let db = + match Manipulation.Memory.create_database storage ~name:"hr" with + | Error _ -> assert false + | Ok db -> db in - let db = match Manipulation.Memory.create_relation storage db ~name:"Department" - ~schema:(Schema.empty |> Schema.add "dept_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Department" + ~schema:(Schema.empty |> Schema.add "dept_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db in - let db = match Manipulation.Memory.create_relation storage db ~name:"Employee" - ~schema:(Schema.empty - |> Schema.add "emp_id" "natural" - |> Schema.add "dept_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Employee" + ~schema: + (Schema.empty + |> Schema.add "emp_id" "natural" + |> Schema.add "dept_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db in let fk_body = let binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id") in - Constraint.Exists { - variable = "d"; - quantifier = "Department"; - body = Constraint.MemberOf { target = "Department"; binding }; - } + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = Constraint.MemberOf { target = "Department"; binding }; + } in - let db = match Manipulation.Memory.register_constraint storage db - ~constraint_name:"fk_dept" - ~relation_name:"Employee" - ~body:fk_body with - | Error _ -> assert false | Ok db -> db + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"fk_dept" ~relation_name:"Employee" ~body:fk_body + with + | Error _ -> assert false + | Ok db -> db in db -let%test_unit "extend_tuple namespacing: insert Employee with non-existent dept_id is rejected" = +let%test_unit + "extend_tuple namespacing: insert Employee with non-existent dept_id is \ + rejected" = (* Regression test for the extend_tuple namespacing bug. Without namespacing, extend_tuple would overwrite the Employee's dept_id=99 with the Department row's dept_id=1 during Exists iteration. Var "dept_id" @@ -3226,202 +3946,346 @@ let%test_unit "extend_tuple namespacing: insert Employee with non-existent dept_ With namespacing, Department attributes are stored as d.dept_id=1 and the base Employee attribute dept_id=99 is preserved, so the check correctly fails. *) with_storage (fun storage -> - let db = setup_fk_db storage in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 1); - ("dept_id", Drl.Ast.Int 99)] }) with - | Ok _ -> assert false (* dept_id=99 does not exist in Department *) - | Error _ -> ()) + let db = setup_fk_db storage in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 1); ("dept_id", Drl.Ast.Int 99) ]; + }) + with + | Ok _ -> assert false (* dept_id=99 does not exist in Department *) + | Error _ -> ()) let%test_unit "cascade: delete referenced row violates FK and is rejected" = with_storage (fun storage -> - let db = setup_fk_db storage in - (* Insert Dept 1 and Employee referencing it *) - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 10); - ("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with - | None -> assert false | Some r -> r - in - let dept_hash = Hashing.hash_tuple - { Tuple.relation = "Department"; - attributes = Tuple.AttributeMap.singleton "dept_id" - { Attribute.value = Obj.magic (1 : int) } } - in - (* Deleting Dept 1 while Employee references it must fail *) - match Manipulation.Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with - | Ok _ -> assert false (* should have been rejected *) - | Error (Manipulation.ConstraintViolation msg) -> - assert (String.length msg > 0) - | Error _ -> assert false) + let db = setup_fk_db storage in + (* Insert Dept 1 and Employee referencing it *) + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 10); ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let dept_rel = + match Manipulation.Memory.get_relation db ~name:"Department" with + | None -> assert false + | Some r -> r + in + let dept_hash = + Hashing.hash_tuple + { + Tuple.relation = "Department"; + attributes = + Tuple.AttributeMap.singleton "dept_id" + { Attribute.value = Obj.magic (1 : int) }; + } + in + (* Deleting Dept 1 while Employee references it must fail *) + match + Manipulation.Memory.retract_tuple storage db dept_rel + ~tuple_hash:dept_hash + with + | Ok _ -> assert false (* should have been rejected *) + | Error (Manipulation.ConstraintViolation msg) -> + assert (String.length msg > 0) + | Error _ -> assert false) let%test_unit "cascade: delete unreferenced row succeeds" = with_storage (fun storage -> - let db = setup_fk_db storage in - (* Insert two departments; employee only references dept 1 *) - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 2)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 10); - ("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with - | None -> assert false | Some r -> r - in - let dept2_hash = Hashing.hash_tuple - { Tuple.relation = "Department"; - attributes = Tuple.AttributeMap.singleton "dept_id" - { Attribute.value = Obj.magic (2 : int) } } - in - (* Deleting unreferenced Dept 2 must succeed *) - match Manipulation.Memory.retract_tuple storage db dept_rel ~tuple_hash:dept2_hash with - | Error _ -> assert false - | Ok (new_db, _) -> - let dept = match Manipulation.Memory.get_relation new_db ~name:"Department" with - | None -> assert false | Some r -> r + let db = setup_fk_db storage in + (* Insert two departments; employee only references dept 1 *) + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 2) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 10); ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db in - assert (Manipulation.Memory.tuple_count dept = 1)) + let dept_rel = + match Manipulation.Memory.get_relation db ~name:"Department" with + | None -> assert false + | Some r -> r + in + let dept2_hash = + Hashing.hash_tuple + { + Tuple.relation = "Department"; + attributes = + Tuple.AttributeMap.singleton "dept_id" + { Attribute.value = Obj.magic (2 : int) }; + } + in + (* Deleting unreferenced Dept 2 must succeed *) + match + Manipulation.Memory.retract_tuple storage db dept_rel + ~tuple_hash:dept2_hash + with + | Error _ -> assert false + | Ok (new_db, _) -> + let dept = + match + Manipulation.Memory.get_relation new_db ~name:"Department" + with + | None -> assert false + | Some r -> r + in + assert (Manipulation.Memory.tuple_count dept = 1)) let%test_unit "cascade: Negative-polarity relation deletion is not checked" = (* Constraint on Employee: NOT (MemberOf Blacklist (emp_id = Var "emp_id")) Blacklist has Negative polarity (INSERT into Blacklist could violate). DELETE from Blacklist should never trigger a cascade check. *) with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"hr" with - | Error _ -> assert false | Ok db -> db - in - let db = match Manipulation.Memory.create_relation storage db ~name:"Blacklist" - ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db - in - let db = match Manipulation.Memory.create_relation storage db ~name:"Employee" - ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db - in - let not_body = - let binding = - Constraint.BindingMap.singleton "emp_id" (Constraint.Var "emp_id") + let db = + match Manipulation.Memory.create_database storage ~name:"hr" with + | Error _ -> assert false + | Ok db -> db in - Constraint.Not { - body = Constraint.MemberOf { target = "Blacklist"; binding }; - universe = "Employee"; - } - in - let db = match Manipulation.Memory.register_constraint storage db - ~constraint_name:"not_blacklisted" - ~relation_name:"Employee" - ~body:not_body with - | Error _ -> assert false | Ok db -> db - in - (* Insert emp_id=5 into Blacklist, then insert emp_id=99 into Employee (unrelated) *) - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Blacklist"; - attributes = [("emp_id", Drl.Ast.Int 5)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 99)] }) with - | Error _ -> assert false | Ok db -> db - in - let bl_rel = match Manipulation.Memory.get_relation db ~name:"Blacklist" with - | None -> assert false | Some r -> r - in - let bl_hash = Hashing.hash_tuple - { Tuple.relation = "Blacklist"; - attributes = Tuple.AttributeMap.singleton "emp_id" - { Attribute.value = Obj.magic (5 : int) } } - in - (* Deleting from Blacklist (negative polarity) must not trigger cascade check *) - match Manipulation.Memory.retract_tuple storage db bl_rel ~tuple_hash:bl_hash with - | Error _ -> assert false - | Ok _ -> ()) + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Blacklist" + ~schema:(Schema.empty |> Schema.add "emp_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Employee" + ~schema:(Schema.empty |> Schema.add "emp_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let not_body = + let binding = + Constraint.BindingMap.singleton "emp_id" (Constraint.Var "emp_id") + in + Constraint.Not + { + body = Constraint.MemberOf { target = "Blacklist"; binding }; + universe = "Employee"; + } + in + let db = + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"not_blacklisted" ~relation_name:"Employee" + ~body:not_body + with + | Error _ -> assert false + | Ok db -> db + in + (* Insert emp_id=5 into Blacklist, then insert emp_id=99 into Employee (unrelated) *) + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Blacklist"; + attributes = [ ("emp_id", Drl.Ast.Int 5) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = [ ("emp_id", Drl.Ast.Int 99) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let bl_rel = + match Manipulation.Memory.get_relation db ~name:"Blacklist" with + | None -> assert false + | Some r -> r + in + let bl_hash = + Hashing.hash_tuple + { + Tuple.relation = "Blacklist"; + attributes = + Tuple.AttributeMap.singleton "emp_id" + { Attribute.value = Obj.magic (5 : int) }; + } + in + (* Deleting from Blacklist (negative polarity) must not trigger cascade check *) + match + Manipulation.Memory.retract_tuple storage db bl_rel ~tuple_hash:bl_hash + with + | Error _ -> assert false + | Ok _ -> ()) let%test_unit "cascade: deferred constraint not checked during retract_tuple" = with_storage (fun storage -> - let db = match Manipulation.Memory.create_database storage ~name:"hr" with - | Error _ -> assert false | Ok db -> db - in - let db = match Manipulation.Memory.create_relation storage db ~name:"Department" - ~schema:(Schema.empty |> Schema.add "dept_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db - in - let db = match Manipulation.Memory.create_relation storage db ~name:"Employee" - ~schema:(Schema.empty - |> Schema.add "emp_id" "natural" - |> Schema.add "dept_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db - in - let fk_body = - let binding = - Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id") + let db = + match Manipulation.Memory.create_database storage ~name:"hr" with + | Error _ -> assert false + | Ok db -> db in - Constraint.Exists { - variable = "d"; - quantifier = "Department"; - body = Constraint.MemberOf { target = "Department"; binding }; - } - in - (* Register as DEFERRED *) - let db = match Manipulation.Memory.attach_constraint storage db - ~constraint_name:"fk_dept_deferred" - ~relation_name:"Employee" - ~body:fk_body - ~timing:Constraint.Deferred with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 10); - ("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with - | None -> assert false | Some r -> r - in - let dept_hash = Hashing.hash_tuple - { Tuple.relation = "Department"; - attributes = Tuple.AttributeMap.singleton "dept_id" - { Attribute.value = Obj.magic (1 : int) } } - in - (* Deferred: retract_tuple itself should NOT reject the deletion *) - match Manipulation.Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with - | Error _ -> assert false (* deferred: must pass here *) - | Ok (new_db, _) -> - (* But check_deferred_constraints must catch the violation *) - match Manipulation.Memory.check_deferred_constraints storage new_db with - | Ok () -> assert false (* should have caught the violation *) - | Error (Manipulation.ConstraintViolation _) -> () - | Error _ -> assert false) + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Department" + ~schema:(Schema.empty |> Schema.add "dept_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Employee" + ~schema: + (Schema.empty + |> Schema.add "emp_id" "natural" + |> Schema.add "dept_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db + in + let fk_body = + let binding = + Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id") + in + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = Constraint.MemberOf { target = "Department"; binding }; + } + in + (* Register as DEFERRED *) + let db = + match + Manipulation.Memory.attach_constraint storage db + ~constraint_name:"fk_dept_deferred" ~relation_name:"Employee" + ~body:fk_body ~timing:Constraint.Deferred + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 10); ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let dept_rel = + match Manipulation.Memory.get_relation db ~name:"Department" with + | None -> assert false + | Some r -> r + in + let dept_hash = + Hashing.hash_tuple + { + Tuple.relation = "Department"; + attributes = + Tuple.AttributeMap.singleton "dept_id" + { Attribute.value = Obj.magic (1 : int) }; + } + in + (* Deferred: retract_tuple itself should NOT reject the deletion *) + match + Manipulation.Memory.retract_tuple storage db dept_rel + ~tuple_hash:dept_hash + with + | Error _ -> assert false (* deferred: must pass here *) + | Ok (new_db, _) -> ( + (* But check_deferred_constraints must catch the violation *) + match + Manipulation.Memory.check_deferred_constraints storage new_db + with + | Ok () -> assert false (* should have caught the violation *) + | Error (Manipulation.ConstraintViolation _) -> () + | Error _ -> assert false)) (* INSERT cascade tests. @@ -3435,64 +4299,109 @@ let%test_unit "cascade: deferred constraint not checked during retract_tuple" = Blacklist has Negative polarity in this constraint, so inserting into Blacklist must trigger a re-check of Employee tuples. *) let setup_blacklist_db storage = - let db = match Manipulation.Memory.create_database storage ~name:"hr" with - | Error _ -> assert false | Ok db -> db + let db = + match Manipulation.Memory.create_database storage ~name:"hr" with + | Error _ -> assert false + | Ok db -> db in - let db = match Manipulation.Memory.create_relation storage db ~name:"Blacklist" - ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Blacklist" + ~schema:(Schema.empty |> Schema.add "emp_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db in - let db = match Manipulation.Memory.create_relation storage db ~name:"Employee" - ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Employee" + ~schema:(Schema.empty |> Schema.add "emp_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db in let not_body = - Constraint.Not { - body = Constraint.MemberOf { - target = "Blacklist"; - binding = Constraint.BindingMap.singleton "emp_id" (Constraint.Var "emp_id"); - }; - universe = "Employee"; - } + Constraint.Not + { + body = + Constraint.MemberOf + { + target = "Blacklist"; + binding = + Constraint.BindingMap.singleton "emp_id" + (Constraint.Var "emp_id"); + }; + universe = "Employee"; + } in - match Manipulation.Memory.register_constraint storage db - ~constraint_name:"not_blacklisted" - ~relation_name:"Employee" - ~body:not_body with - | Error _ -> assert false | Ok db -> db + match + Manipulation.Memory.register_constraint storage db + ~constraint_name:"not_blacklisted" ~relation_name:"Employee" + ~body:not_body + with + | Error _ -> assert false + | Ok db -> db -let%test_unit "cascade INSERT: inserting into Blacklist violates constraint on existing Employee" = +let%test_unit + "cascade INSERT: inserting into Blacklist violates constraint on existing \ + Employee" = (* Employee emp_id=5 already exists. Inserting Blacklist{emp_id=5} must be rejected because the Employee constraint (NOT member of Blacklist) would be violated for the existing emp_id=5 row. *) with_storage (fun storage -> - let db = setup_blacklist_db storage in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 5)] }) with - | Error _ -> assert false | Ok db -> db - in - match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Blacklist"; - attributes = [("emp_id", Drl.Ast.Int 5)] }) with - | Ok _ -> assert false (* emp_id=5 exists in Employee, must be rejected *) - | Error _ -> ()) + let db = setup_blacklist_db storage in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = [ ("emp_id", Drl.Ast.Int 5) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Blacklist"; + attributes = [ ("emp_id", Drl.Ast.Int 5) ]; + }) + with + | Ok _ -> assert false (* emp_id=5 exists in Employee, must be rejected *) + | Error _ -> ()) -let%test_unit "cascade INSERT: inserting into Blacklist with no matching Employee succeeds" = +let%test_unit + "cascade INSERT: inserting into Blacklist with no matching Employee \ + succeeds" = (* Employee emp_id=99 does not exist. Inserting Blacklist{emp_id=5} must succeed because no Employee tuple is affected. *) with_storage (fun storage -> - let db = setup_blacklist_db storage in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 99)] }) with - | Error _ -> assert false | Ok db -> db - in - match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Blacklist"; - attributes = [("emp_id", Drl.Ast.Int 5)] }) with - | Error _ -> assert false (* emp_id=5 not in Employee, must succeed *) - | Ok _ -> ()) + let db = setup_blacklist_db storage in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = [ ("emp_id", Drl.Ast.Int 99) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Blacklist"; + attributes = [ ("emp_id", Drl.Ast.Int 5) ]; + }) + with + | Error _ -> assert false (* emp_id=5 not in Employee, must succeed *) + | Ok _ -> ()) (* commit tests. @@ -3500,108 +4409,179 @@ let%test_unit "cascade INSERT: inserting into Blacklist with no matching Employe Individual mutations succeed even when they temporarily violate the constraint; commit is the boundary where deferred violations are caught. *) let setup_deferred_fk_db storage = - let db = match Manipulation.Memory.create_database storage ~name:"hr" with - | Error _ -> assert false | Ok db -> db + let db = + match Manipulation.Memory.create_database storage ~name:"hr" with + | Error _ -> assert false + | Ok db -> db in - let db = match Manipulation.Memory.create_relation storage db ~name:"Department" - ~schema:(Schema.empty |> Schema.add "dept_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Department" + ~schema:(Schema.empty |> Schema.add "dept_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db in - let db = match Manipulation.Memory.create_relation storage db ~name:"Employee" - ~schema:(Schema.empty - |> Schema.add "emp_id" "natural" - |> Schema.add "dept_id" "natural") with - | Error _ -> assert false | Ok (db, _) -> db + let db = + match + Manipulation.Memory.create_relation storage db ~name:"Employee" + ~schema: + (Schema.empty + |> Schema.add "emp_id" "natural" + |> Schema.add "dept_id" "natural") + with + | Error _ -> assert false + | Ok (db, _) -> db in let fk_body = - Constraint.Exists { - variable = "d"; quantifier = "Department"; - body = Constraint.MemberOf { - target = "Department"; - binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id"); - }; - } + Constraint.Exists + { + variable = "d"; + quantifier = "Department"; + body = + Constraint.MemberOf + { + target = "Department"; + binding = + Constraint.BindingMap.singleton "dept_id" + (Constraint.Var "dept_id"); + }; + } in - match Manipulation.Memory.attach_constraint storage db - ~constraint_name:"fk_dept" - ~relation_name:"Employee" - ~body:fk_body - ~timing:Constraint.Deferred with - | Error _ -> assert false | Ok db -> db + match + Manipulation.Memory.attach_constraint storage db ~constraint_name:"fk_dept" + ~relation_name:"Employee" ~body:fk_body ~timing:Constraint.Deferred + with + | Error _ -> assert false + | Ok db -> db let%test_unit "commit: no deferred constraints, returns Ok with db unchanged" = with_storage (fun storage -> - let db = setup_deferred_fk_db storage in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 10); - ("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - (* All constraints satisfied, commit must pass *) - match Manipulation.Memory.commit storage db with - | Error _ -> assert false - | Ok _ -> ()) + let db = setup_deferred_fk_db storage in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 10); ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + (* All constraints satisfied, commit must pass *) + match Manipulation.Memory.commit storage db with + | Error _ -> assert false + | Ok _ -> ()) let%test_unit "commit: deferred violation is caught at commit boundary" = with_storage (fun storage -> - let db = setup_deferred_fk_db storage in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 10); - ("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with - | None -> assert false | Some r -> r - in - let dept_hash = Hashing.hash_tuple - { Tuple.relation = "Department"; - attributes = Tuple.AttributeMap.singleton "dept_id" - { Attribute.value = Obj.magic (1 : int) } } - in - (* Delete the referenced department. Deferred, so retract succeeds *) - let db = match Manipulation.Memory.retract_tuple storage db dept_rel - ~tuple_hash:dept_hash with - | Error _ -> assert false | Ok (db, _) -> db - in - (* commit must now catch the orphaned Employee *) - match Manipulation.Memory.commit storage db with - | Ok _ -> assert false - | Error (Manipulation.ConstraintViolation _) -> () - | Error _ -> assert false) + let db = setup_deferred_fk_db storage in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 10); ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let dept_rel = + match Manipulation.Memory.get_relation db ~name:"Department" with + | None -> assert false + | Some r -> r + in + let dept_hash = + Hashing.hash_tuple + { + Tuple.relation = "Department"; + attributes = + Tuple.AttributeMap.singleton "dept_id" + { Attribute.value = Obj.magic (1 : int) }; + } + in + (* Delete the referenced department. Deferred, so retract succeeds *) + let db = + match + Manipulation.Memory.retract_tuple storage db dept_rel + ~tuple_hash:dept_hash + with + | Error _ -> assert false + | Ok (db, _) -> db + in + (* commit must now catch the orphaned Employee *) + match Manipulation.Memory.commit storage db with + | Ok _ -> assert false + | Error (Manipulation.ConstraintViolation _) -> () + | Error _ -> assert false) let%test_unit "commit: clears deferred list, second commit passes" = (* After a successful commit the deferred list is empty. A follow-up mutation + commit on the returned db must also work correctly rather than re-running stale entries from the previous window. *) with_storage (fun storage -> - let db = setup_deferred_fk_db storage in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Department"; - attributes = [("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Dml.Executor.Memory.execute storage db - (Dml.Ast.InsertTuple { relation = "Employee"; - attributes = [("emp_id", Drl.Ast.Int 10); - ("dept_id", Drl.Ast.Int 1)] }) with - | Error _ -> assert false | Ok db -> db - in - let db = match Manipulation.Memory.commit storage db with - | Error _ -> assert false | Ok db -> db - in - (* Second commit with no new mutations must also pass *) - match Manipulation.Memory.commit storage db with - | Error _ -> assert false - | Ok _ -> ()) + let db = setup_deferred_fk_db storage in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Department"; + attributes = [ ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match + Dml.Executor.Memory.execute storage db + (Dml.Ast.InsertTuple + { + relation = "Employee"; + attributes = + [ ("emp_id", Drl.Ast.Int 10); ("dept_id", Drl.Ast.Int 1) ]; + }) + with + | Error _ -> assert false + | Ok db -> db + in + let db = + match Manipulation.Memory.commit storage db with + | Error _ -> assert false + | Ok db -> db + in + (* Second commit with no new mutations must also pass *) + match Manipulation.Memory.commit storage db with + | Error _ -> assert false + | Ok _ -> ()) |