From e6661bfa6a3d7dc477d0b7717c80bd536eca2d68 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 14 Mar 2026 11:39:04 -0300 Subject: =?UTF-8?q?Branching=20and=20na=C3=AFve=20merge=20strategies?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * AGPL license * branching and merging * Delete LICENSE in favor of separate PR Signed-off-by: Marcos Magueta * add unmonitored tests and docs --------- Signed-off-by: Marcos Magueta --- bin/server.ml | 119 +++++++--- docs/dcl-quantification.org | 480 ----------------------------------------- docs/dcl.org | 105 +++++++++ docs/icl-quantification.org | 480 +++++++++++++++++++++++++++++++++++++++++ docs/icl.org | 108 ++++++++++ docs/karuta-integration.org | 26 ++- docs/n-way-binding.org | 8 +- lib/dcl/ast.ml | 24 +-- lib/dcl/executor.ml | 126 +++++++---- lib/dcl/parser.ml | 8 +- lib/icl/ast.ml | 23 ++ lib/icl/executor.ml | 50 +++++ lib/icl/parser.ml | 9 + lib/management/branch.ml | 138 ++++++++++++ lib/management/diff.ml | 60 ++++++ lib/management/merge.ml | 235 ++++++++++++++++++++ lib/manipulation.ml | 2 + lib/prelude/catalog.ml | 3 + test/test_relational_engine.ml | 296 ++++++++++++++++++++++--- 19 files changed, 1701 insertions(+), 599 deletions(-) delete mode 100644 docs/dcl-quantification.org create mode 100644 docs/dcl.org create mode 100644 docs/icl-quantification.org create mode 100644 docs/icl.org create mode 100644 lib/icl/ast.ml create mode 100644 lib/icl/executor.ml create mode 100644 lib/icl/parser.ml create mode 100644 lib/management/branch.ml create mode 100644 lib/management/diff.ml create mode 100644 lib/management/merge.ml diff --git a/bin/server.ml b/bin/server.ml index e669489..2c84468 100644 --- a/bin/server.ml +++ b/bin/server.ml @@ -34,13 +34,20 @@ 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) + +let get_branch storage = + 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])) -let relation_to_sexp storage (db_hash : string) (rel : Relation.t) limit = +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) @@ -55,22 +62,28 @@ let relation_to_sexp storage (db_hash : string) (rel : Relation.t) limit = 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 db_hash msg = +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)]; ] -let error_response db_hash msg = +let error_response storage db_name db_hash msg = let open Sexplib.Sexp in to_string @@ List [ Atom "error"; 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 manip_err = function @@ -85,9 +98,18 @@ let manip_err = function a valid DRL expression that happens to also parse as DML would silently be treated as DRL. The three sublanguages should share a common envelope, e.g. a top-level tag distinguishing (Query ...) from (Exec ...). *) +let advance_head_branch storage new_hash = + match BranchOps.get_head storage with + | Ok (Some branch_name) -> + ignore (BranchOps.update_tip storage ~name:branch_name ~tip:new_hash) + | _ -> () + let 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 (* TODO: (schema) is a stopgap. Introspection should be expressible in DRL itself via the catalog relations, not special-cased here. *) let cmd = match String.trim cmd with @@ -97,39 +119,53 @@ let execute_command storage db_ref cmd = match Drl.Parser.of_string cmd with | Ok query -> (match Drl.Executor.Memory.execute storage db query with - | Ok rel -> relation_to_sexp storage h rel default_limit + | Ok rel -> relation_to_sexp storage name h rel default_limit | Error (Drl.Executor.Memory.RelationNotFound s) -> - error_response h ("RelationNotFound: " ^ s) + err h ("RelationNotFound: " ^ s) | Error (Drl.Executor.Memory.AlgebraError (Algebra.StorageError s)) -> - error_response h ("StorageError: " ^ s) + err h ("StorageError: " ^ s) | Error (Drl.Executor.Memory.AlgebraError (Algebra.GeneratorError s)) -> - error_response h ("GeneratorError: " ^ s)) + err h ("GeneratorError: " ^ s)) | Error _ -> match Dml.Parser.of_string cmd with | Ok stmt -> (match Dml.Executor.Memory.execute storage db stmt with | Ok new_db -> db_ref := new_db; - ok_response new_db.Management.Database.hash "Database updated" + advance_head_branch storage new_db.Management.Database.hash; + ok new_db.Management.Database.hash "updated" | Error (Dml.Executor.Memory.ManipulationError me) -> - error_response h (manip_err me) + err h (manip_err me) | Error (Dml.Executor.Memory.RelationNotFound s) -> - error_response h ("RelationNotFound: " ^ s) + err h ("RelationNotFound: " ^ s) | Error (Dml.Executor.Memory.ParseError s) -> - error_response h ("ParseError: " ^ s)) + err h ("ParseError: " ^ s)) | Error _ -> - match Dcl.Parser.of_string cmd with + match Icl.Parser.of_string cmd with | Ok stmt -> - (match Dcl.Executor.Memory.execute storage db stmt with - | Ok new_db -> + (match Icl.Executor.Memory.execute storage db stmt with + | Ok (new_db, msg) -> db_ref := new_db; - ok_response new_db.Management.Database.hash "Constraint registered" - | Error (Dcl.Executor.Memory.ManipulationError me) -> - error_response h (manip_err me) - | Error (Dcl.Executor.Memory.ConversionError s) -> - error_response h ("ConversionError: " ^ s)) + advance_head_branch storage new_db.Management.Database.hash; + ok new_db.Management.Database.hash msg + | Error (Icl.Executor.Memory.ManipulationError me) -> + err h (manip_err me) + | Error (Icl.Executor.Memory.ConversionError s) -> + err h ("ConversionError: " ^ s)) | Error _ -> - error_response h "Parse error: not valid DRL, DML, or DCL" + match Dcl.Parser.of_string cmd with + | Ok stmt -> + (match Dcl.Executor.Memory.execute storage db stmt with + | Ok (new_db, msg) -> + db_ref := new_db; + advance_head_branch storage new_db.Management.Database.hash; + ok new_db.Management.Database.hash msg + | Error (Dcl.Executor.Memory.BranchError s) -> + err h ("BranchError: " ^ s) + | Error (Dcl.Executor.Memory.MergeError s) -> + err h ("MergeError: " ^ s)) + | Error _ -> + err h "ParseError: not valid DRL, DML, ICL, or DCL" (* TODO: registration failures are silently ignored; a broken prelude relation leaves the catalog in a partially-seeded state with no @@ -146,7 +182,10 @@ let register_prelude_relations storage db = ~cardinality:rel.cardinality with | Ok (new_db, _) -> new_db - | Error _ -> db) + | Error e -> + Printf.eprintf "Warning: failed to register prelude relation %s: %s\n%!" + rel.name (manip_err e); + db) db [ less_than_natural ; less_than_or_equal_natural @@ -174,7 +213,8 @@ let handle_client storage db_ref fd = try execute_command storage db_ref line with e -> let db = !db_ref in - error_response db.Management.Database.hash + error_response storage db.Management.Database.name + db.Management.Database.hash ("Uncaught error: " ^ Printexc.to_string e) in output_string oc (response ^ "\n"); @@ -311,6 +351,37 @@ let () = | Error _ -> failwith "Failed to create initial database" | Ok db -> let db = register_prelude_relations storage db in + (* Register ephemeral sakura:branch and sakura:head relations backed by + the raw branch registry — no stored tuples, no circularity. *) + let db = + let register db rel = + match Manipulation.Memory.create_immutable_relation storage db + ~name:rel.Relation.name + ~schema:rel.Relation.schema + ~generator:(Option.get rel.Relation.generator) + ~membership_criteria:rel.Relation.membership_criteria + ~cardinality:rel.Relation.cardinality + with + | Ok (db, _) -> db + | Error e -> + Printf.eprintf "Warning: failed to register %s: %s\n%!" + rel.Relation.name (match e with + | Manipulation.RelationAlreadyExists s -> "already exists: " ^ s + | Manipulation.StorageError s -> s | _ -> "error"); + db + in + let db = register db (BranchOps.branch_relation storage) in + let db = register db (BranchOps.head_relation storage) in + db + in + (* Create default master branch in raw registry and set HEAD *) + (match BranchOps.create storage ~name:"master" + ~tip:db.Management.Database.hash with + | Error e -> Printf.eprintf "Warning: failed to create master branch: %s\n%!" e + | Ok () -> ()); + (match BranchOps.checkout storage "master" with + | Error e -> Printf.eprintf "Warning: failed to checkout master: %s\n%!" e + | Ok () -> ()); let db_ref = ref db in let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.setsockopt sock Unix.SO_REUSEADDR true; diff --git a/docs/dcl-quantification.org b/docs/dcl-quantification.org deleted file mode 100644 index 81e9cad..0000000 --- a/docs/dcl-quantification.org +++ /dev/null @@ -1,480 +0,0 @@ -#+TITLE: DCL Quantification: Runtime Model and Evaluation - -* Overview - -This document describes precisely how DCL constraints are represented, compiled, -and evaluated at runtime. It covers the full stack from the s-expression syntax -through AST compilation, context construction, and recursive evaluation — with -particular attention to the cost model of quantifiers, which is the primary target -for future performance work. - -* Constraint Type (~lib/constraint.ml~) - -The runtime constraint type is an algebraic tree: - -#+begin_src ocaml -type t = - | MemberOf of { target : relation_name; binding : binding } - | Not of { body : t; universe : relation_name } - | And of t list - | Or of t list - | Exists of { variable : attr_name; quantifier : relation_name; body : t } - | Forall of { variable : attr_name; quantifier : relation_name; body : t } -#+end_src - -A ~binding~ is a ~BindingMap~ (a ~Map.Make(String)~) from target attribute names -to ~binding_expr~: - -#+begin_src ocaml -type binding_expr = - | Var of attr_name (* resolved from current tuple at eval time *) - | Const of Conventions.AbstractValue.t (* literal, resolved at compile time *) -#+end_src - -The ~variable~ field in ~Exists~ and ~Forall~ names the bound tuple for use in -~Var~ expressions inside the body. Attributes from the quantifier row are merged -into the evaluation tuple under the prefix ~variable ^ "."~, so ~(Var "d.dept_id")~ -unambiguously refers to the ~dept_id~ attribute of the tuple bound to variable ~"d"~. -See [[*Tuple Extension: ~extend_tuple~][Tuple Extension: extend_tuple]] for the implementation and [[*The Variable Namespacing Problem][The Variable Namespacing Problem]] -for the history of the bug this fixes. - -* Evaluation Context (~eval_context~) - -Evaluation does not access storage or the database directly. It works through an -~eval_context~ record built once per insert operation and closed over a specific -~(storage, db)~ snapshot: - -#+begin_src ocaml -type eval_context = { - check_membership : - relation_name -> - (attr_name * Conventions.AbstractValue.t) list -> - bool; - iterate_finite : - relation_name -> - (attr_name * Conventions.AbstractValue.t) list list option; -} -#+end_src - -Both fields are closures. This indirection decouples ~Constraint.evaluate~ from -the storage backend and allows the same constraint tree to be evaluated against -different snapshots. - -** ~check_membership~ - -Built in ~Manipulation.Make.build_eval_context~. Given a relation name and a list -of ~(attr_name, value)~ pairs, it returns ~true~ iff a tuple exists in the named -relation whose attributes match every pair in the list. - -The implementation: -1. Looks up the relation in the ~db~ snapshot. -2. Constructs a synthetic ~Tuple.Materialized~ from the bound pairs and runs - ~rel.membership_criteria~ against it. If it fails, returns ~false~ immediately. -3. If the relation has no Merkle tree (ephemeral/generator relation), - ~membership_criteria~ alone is trusted and the function returns ~true~. -4. If the relation has a tree, it calls ~Merkle.keys tree~ to obtain *all* tuple - hashes, then linearly scans them. For each hash it: - a. Loads the raw bytes from storage (~Storage.load_raw~). - b. Deserialises the ~Storable.Tuple.t~ to get the attribute hash list. - c. For each bound pair ~(bk, bv)~, finds the matching attribute by name, loads - its value bytes from storage (~Storage.load_raw~ again), unmarshals it, and - compares with ~Stdlib.(=)~. - d. Short-circuits to ~true~ on the first tuple that satisfies all pairs. - e. Returns ~false~ if no tuple matches. - -The cost of a single ~check_membership~ call on a relation of cardinality /n/ with -/a/ bound attributes and average /k/ attributes per stored tuple is: - - O(n · (1 + a · k)) storage round-trips in the worst case. - -No indexes exist. Every check is a full table scan at the storage level. - -** ~iterate_finite~ - -Given a relation name, returns ~Some rows~ where ~rows~ is a fully materialised -list of rows, each a ~(attr_name * AbstractValue.t) list~. Returns ~None~ if the -relation has infinite or unconstrained cardinality -(~AlephZero~ or ~Continuum~ in ~Conventions.Cardinality~). - -Only relations with cardinality ~Finite _~ or ~ConstrainedFinite~ are iterable. -Generator-based relations with no tree return ~Some []~. - -The materialisation path: -1. ~Merkle.keys tree~ — loads all tuple hashes. -2. For each hash: ~Storage.load_raw~ → ~Storable.Tuple.of_bytes~ → attribute hash list. -3. For each attribute hash: ~Storage.load_raw~ → ~Marshal.from_bytes~. - -This eagerly materialises the *entire* quantifier relation into memory before -evaluation begins. For a relation of cardinality /n/ with /k/ attributes each, -the cost is O(n · k) storage loads and the full result occupies O(n · k) memory. - -* Variable Resolution: ~bind~ - -Before a ~MemberOf~ check is executed, the binding map is resolved against the -current tuple via ~bind~: - -#+begin_src ocaml -let bind (b : binding) (tuple : Tuple.materialized) - : (attr_name * Conventions.AbstractValue.t) list = - BindingMap.fold - (fun target_attr expr acc -> - let value = match expr with - | Const v -> Some v - | Var src_attr -> - match Tuple.AttributeMap.find_opt src_attr tuple.attributes with - | Some attr -> Some attr.Attribute.value - | None -> None - in - match value with - | Some v -> (target_attr, v) :: acc - | None -> acc) - b [] -#+end_src - -Key behaviour: -- ~Const v~ is lifted directly; no attribute lookup. -- ~Var src_attr~ looks up ~src_attr~ in ~tuple.attributes~. If the attribute is - absent, the pair is *silently dropped* from the bound list. A ~MemberOf~ with - incomplete bindings may match unintended tuples or always pass if the target - relation contains tuples with fewer attributes. -- The result is a plain assoc list, not a map; duplicate keys are possible if - the binding contains both a ~Const~ and a ~Var~ targeting the same name. - -* Tuple Extension: ~extend_tuple~ - -When a quantifier (~Exists~ or ~Forall~) iterates over a row, it extends the -current evaluation tuple by merging that row's attributes in: - -#+begin_src ocaml -and extend_tuple (tuple : Tuple.materialized) - (variable : attr_name) - (row : (attr_name * Conventions.AbstractValue.t) list) - : Tuple.materialized = - let extra_attrs = - List.fold_left - (fun acc (k, v) -> - Tuple.AttributeMap.add (variable ^ "." ^ k) { Attribute.value = v } acc) - tuple.attributes row - in - { tuple with attributes = extra_attrs } -#+end_src - -Two important facts: - -1. *Quantifier attributes are namespaced by the variable name.* Each attribute ~k~ - from the quantifier row is inserted as ~variable ^ "." ^ k~. The incoming tuple's - own attributes are never overwritten. ~(Var "dept_id")~ resolves to the base - tuple's value; ~(Var "d.dept_id")~ resolves to the value contributed by the - quantifier bound to ~"d"~. See [[*The Variable Namespacing Problem][The Variable Namespacing Problem]] for the - earlier behaviour where ~variable~ was ignored and overwrites were silent. - -2. *A new ~AttributeMap~ is allocated on every extend call.* With /a/ existing - attributes and /r/ new attributes from the row, ~fold_left~ performs /r/ - ~AttributeMap.add~ operations each building on the previous map. For /q/ - nested quantifiers of cardinalities /n₁, n₂, ..., nq/, ~extend_tuple~ is - called /n₁ · n₂ · ... · nq/ times total — once per combination. - -* Recursive Evaluation: ~evaluate~ - -#+begin_src ocaml -let rec evaluate (ctx : eval_context) (tuple : Tuple.materialized) (c : t) - : (bool, diagnostic) result = -#+end_src - -The function is structurally recursive over the constraint tree. Each case: - -** ~MemberOf~ - -#+begin_src ocaml -| MemberOf { target; binding } -> - let bound_values = bind binding tuple in - if ctx.check_membership target bound_values then Ok true - else Error (MembershipFailed { target; bound_values }) -#+end_src - -Resolves bindings from the current tuple (O(|binding|) attribute lookups), then -delegates to ~check_membership~. Returns ~Ok true~ or ~Error~ (never ~Ok false~) -— the ~Ok false~ branch of ~Exists~/~Forall~ is distinguished from ~Error~. - -** ~Not~ - -#+begin_src ocaml -| Not { body; universe = _ } -> - match evaluate ctx tuple body with - | Ok true -> Ok false - | Ok false -> Ok true - | Error (MembershipFailed _) -> Ok true - | Error d -> Error d -#+end_src - -~MembershipFailed~ from the body is treated as ~Ok true~ (negation of a failed -membership = the tuple is not a member = negation succeeds). The ~universe~ field -is a declarative annotation for closed-world reasoning and is not used at runtime. - -** ~And~ / ~Or~ - -Both use short-circuit evaluation: -- ~And~: stops at the first ~Ok false~ or ~Error~. -- ~Or~: stops at the first ~Ok true~; swallows ~Error~ branches and continues. - -Neither produces diagnostics for the other branches once a decision is reached. -Note that ~evaluate_named~ (which evaluates all named constraints on a tuple) does -*not* short-circuit — it collects all failures before returning. - -** ~Exists~ - -#+begin_src ocaml -| Exists { variable; quantifier; body } -> - match ctx.iterate_finite quantifier with - | None -> Error (UnboundedQuantifier { variable; quantifier }) - | Some rows -> - let rec check = function - | [] -> Ok false - | row :: rest -> - let extended_tuple = extend_tuple tuple variable row in - match evaluate ctx extended_tuple body with - | Ok true -> Ok true - | Ok false -> check rest - | Error _ -> check rest - in - check rows -#+end_src - -The execution model: -1. ~iterate_finite~ is called, fully materialising the quantifier relation. -2. Rows are iterated sequentially. For each row, ~extend_tuple~ merges it into - the current tuple, and ~evaluate~ recurses into the body. -3. The first ~Ok true~ short-circuits: remaining rows are not evaluated. -4. Both ~Ok false~ and ~Error~ from the body are treated identically — the row is - skipped and iteration continues. *Errors inside the body of an ~Exists~ are - silently discarded.* -5. If all rows are exhausted without ~Ok true~, returns ~Ok false~. - -An ~Exists~ over a relation of cardinality /n/ with a body whose evaluation cost -is /C/ has worst-case cost O(n · C). Nesting two ~Exists~ quantifiers over -relations of cardinalities /n/ and /m/ has worst-case cost O(n · m · C). -In general, /q/ nested quantifiers produce O(∏ nᵢ · C) body evaluations — a -Cartesian product. - -** ~Forall~ - -#+begin_src ocaml -| Forall { variable; quantifier; body } -> - match ctx.iterate_finite quantifier with - | None -> Error (UnboundedQuantifier { variable; quantifier }) - | Some rows -> - let rec check = function - | [] -> Ok true - | row :: rest -> - let extended_tuple = extend_tuple tuple variable row in - match evaluate ctx extended_tuple body with - | Ok true -> check rest - | Ok false -> Ok false - | Error (MembershipFailed _) -> Ok false - | Error d -> Error d - in - check rows -#+end_src - -Symmetric to ~Exists~ but short-circuits on ~Ok false~ or ~MembershipFailed~. -Unlike ~Exists~, other ~Error~ variants (e.g., ~UnboundedQuantifier~) are -propagated rather than silently consumed. The cost model is identical: O(∏ nᵢ · C). - -* The Variable Namespacing Problem - -This section documents the original bug and explains why the current implementation -is correct. In the initial implementation, ~extend_tuple~ took ~variable~ as -~_variable~ — a named-but-discarded argument — and merged quantifier row attributes -flat into the tuple under their original names. This had two consequences. - -** Attribute Shadowing (fixed) - -If the incoming tuple and the quantifier row shared an attribute name, the -quantifier's value won silently. Concretely: an Employee with ~dept_id=99~ being -checked by an ~Exists~ over Department rows would have its ~dept_id~ overwritten -by each Department row's ~dept_id~ in turn. ~(Var "dept_id")~ in the body then -resolved to the Department's own id, not the Employee's. An FK constraint written -as ~(MemberOf (target "Department") (binding ((dept_id (Var "dept_id")))))~ inside -an ~Exists~ over Department would always pass — it was validating the Department -against itself rather than checking whether the Employee's ~dept_id~ existed. - -** Multi-Quantifier Ambiguity (fixed) - -With two nested quantifiers over relations sharing attribute names, the inner -quantifier's pass through ~extend_tuple~ overwrote what the outer one had written. -There was no way to write a body that simultaneously referred to attributes from -two distinct quantifier rows of the same name. - -** Resolution - -Both problems are resolved by namespacing: each attribute ~k~ from the quantifier -row is stored as ~variable ^ "." ^ k~. The base tuple is never modified. The -~variable~ argument, previously discarded as ~_variable~, is now the namespace -prefix. The fix is in ~lib/constraint.ml~ with an inline TODO describing the -deeper issue of tuple-level provenance as a structural solution. - -* N-Ary Quantification - -The current AST represents each quantifier as a single ~(variable, quantifier)~ -pair. N-ary constraints across three or more relations require nesting: - -#+begin_src lisp -(Exists (variable "b") (quantifier "Building") - (Exists (variable "r") (quantifier "Room") - (Exists (variable "s") (quantifier "Suite") - ...))) -#+end_src - -This is semantically correct once namespacing is in place, but verbose and implies -a strict left-to-right evaluation order with no opportunity for reordering. - -The proposed n-ary form makes the binding list first-class: - -#+begin_src lisp -(Exists - (bindings ((b "Building") (r "Room") (s "Suite"))) - (body ...)) -#+end_src - -The executor folds over the binding list left-to-right, extending the tuple at -each step — equivalent to nested ~Exists~ but expressed as a single node: - -#+begin_src ocaml -| Exists { bindings; body } -> - let rec go bindings tuple = - match bindings with - | [] -> evaluate ctx tuple body - | (variable, quantifier) :: rest -> - match ctx.iterate_finite quantifier with - | None -> Error (UnboundedQuantifier { variable; quantifier }) - | Some rows -> - let rec check = function - | [] -> Ok false - | row :: rest' -> - let extended = extend_tuple tuple variable row in - match go rest extended with - | Ok true -> Ok true - | Ok false | Error _ -> check rest' - in - check rows - in - go bindings tuple -#+end_src - -The cost remains O(∏ nᵢ · C) — the n-ary form does not change the complexity, -but it makes the binding structure explicit and opens the door to reordering -optimisations (e.g., evaluate the smallest relation first). - -* Performance Inventory - -The following is a precise account of known costs and inefficiencies, intended -as a reference for future optimisation work. - -** Eager Full Materialisation of Quantifier Relations - -~iterate_finite~ loads every tuple in the quantifier relation from storage before -the first body evaluation begins. For a ~Forall~ whose first body call returns -~Ok false~, all subsequent tuples were loaded needlessly. A streaming/lazy -iterator would allow early termination before full materialisation. - -** Linear Scan in ~check_membership~ - -Every ~MemberOf~ check performs a full linear scan over all tuple hashes in the -target relation's Merkle tree. There are no secondary indexes. For a relation of -cardinality /n/: - -- /n/ calls to ~Storage.load_raw~ to fetch stored tuples. -- For each tuple, up to /a/ additional ~Storage.load_raw~ calls to fetch - attribute values. -- Comparison via structural equality (~Stdlib.(=)~) on unmarshalled ~Obj.t~ values. - -An index mapping ~(relation_name, attr_name, value_hash)~ to tuple hashes would -reduce this to O(log n) or O(1) per ~MemberOf~ check. - -** AttributeMap Allocation per ~extend_tuple~ Call - -~extend_tuple~ allocates a new ~AttributeMap~ on every invocation by folding over -the row into the existing map. For nested quantifiers of cardinalities -/n₁ × n₂ × ... × nq/, this allocates ∏ nᵢ maps during a single constraint check. -A persistent/functional map amortises this somewhat (structural sharing), but -each call still produces a new root node. - -A flat association list or array, indexed by a fixed schema, would be cheaper -for extend and lookup at the cost of schema rigidity. - -** Redundant Storage Loads Across Constraints - -The ~eval_context~ is built once per ~create_tuple~ call, but it is not a cache — -every ~check_membership~ and ~iterate_finite~ call re-reads from storage. If a -relation is referenced in multiple constraints or multiple ~MemberOf~ nodes within -one constraint tree, its tuples are loaded multiple times. - -A constraint-session cache (a ~Hashtbl~ from relation_name to materialised rows, -populated lazily on first access) would eliminate redundant loads within a single -tuple insertion. - -** No Short-Circuit Across Named Constraints - -~evaluate_named~ evaluates every constraint in the named list, collecting all -failures before returning: - -#+begin_src ocaml -let failures = - List.filter_map - (fun (name, c) -> - match evaluate ctx tuple c with - | Ok true -> None - | Ok false -> Some (name, ...) - | Error d -> Some (name, d)) - named -in -#+end_src - -For a tuple that violates the first constraint, all remaining constraints are -still evaluated at full cost. Short-circuiting on first failure is correct when -complete diagnostics are not required (e.g., interactive insertion). A lazy stream -of failures, computed on demand, would support both use cases. - -** Cartesian Product Complexity of Nested Quantifiers - -For /q/ nested ~Exists~/~Forall~ quantifiers over relations of cardinalities -/n₁, n₂, ..., nq/ with body cost /C/: - - Worst-case body evaluations = n₁ × n₂ × ... × nq - - Worst-case storage loads = (∑ nᵢ · kᵢ) + n₁ · n₂ · ... · nq · C_membership - -Where /kᵢ/ is the attribute count of relation /i/ and /C_membership/ is the cost -of ~check_membership~ on the body's target relation. - -Mitigations: -- *Evaluate smallest relation first* (selectivity-based reordering): reduces the - Cartesian product by pruning earlier. -- *Push ~MemberOf~ filters into the iteration*: instead of iterating all rows of - the quantifier relation and then checking membership, filter the quantifier rows - during iteration using the same index that would accelerate ~check_membership~. -- *Semi-join reduction*: for FK-style constraints, a single hash lookup suffices - and no Cartesian product is needed. - -* Summary of Call Chain for a Single Tuple Insertion - -#+begin_example -create_tuple - └── build_eval_context (storage, db) [once per insertion] - └── evaluate_named ctx tuple named_constraints [once per insertion] - └── evaluate ctx tuple c [once per named constraint] - ├── Exists / Forall - │ └── iterate_finite quantifier [materialises full relation] - │ ├── Merkle.keys tree - │ └── Storage.load_raw × (n × k) - │ └── for each row: - │ ├── extend_tuple [allocates new AttributeMap] - │ └── evaluate ctx extended_tuple body - │ └── MemberOf - │ ├── bind [resolves Vars from extended tuple] - │ └── check_membership target bound_values - │ ├── Merkle.keys tree - │ └── Storage.load_raw × (n' × (1 + a)) - └── And / Or / Not - └── evaluate (recursive) -#+end_example diff --git a/docs/dcl.org b/docs/dcl.org new file mode 100644 index 0000000..92fc19d --- /dev/null +++ b/docs/dcl.org @@ -0,0 +1,105 @@ +#+TITLE: DCL — Database Control Language + +DCL manages branches: named pointers to database states. It provides +Git-like operations built on Sakura's append-only, content-addressed +storage. Every mutation automatically advances the current branch tip, +so you never need to track hashes manually. + +* Syntax reference + +| Command | Effect | +|--------------------------------------------+--------------------------------------| +| ~(CreateBranch (name N))~ | Create branch N at current state | +| ~(CreateBranch (name N) (hash H))~ | Create branch N at a specific hash | +| ~(Checkout N)~ | Switch to branch N, restore its db | +| ~(GetHead)~ | Print the current HEAD branch name | +| ~(GetBranchTip N)~ | Print the stored hash of branch N | +| ~(UpdateBranchTip (name N) (hash H))~ | Manually advance branch N to hash H | +| ~(Merge (left L) (right R) (strategy S))~ | 3-way merge branch R into L | + +Branch state is always queryable as relations: + +#+begin_src sexp +(Base sakura:branch) ; name × hash for every branch +(Base sakura:head) ; single-tuple: current branch name +#+end_src + +Merge strategies: + +| Strategy | Behaviour on conflict | +|--------------------+----------------------------------------------| +| ~PreferLeft~ | Keep the left branch's version | +| ~PreferRight~ | Keep the right branch's version | +| ~RevertToAncestor~ | Revert conflicting relation to the LCA state | + +* Example: travelling through history + +#+begin_src sexp +(CreateRelation (name "scores") (schema ((player "string") (pts "integer")))) + +(CreateBranch (name "v0")) + +(InsertTuple (relation "scores") (attributes ((player (Str "Alice")) (pts (Int 10))))) + +(CreateBranch (name "v1")) + +(InsertTuple (relation "scores") (attributes ((player (Str "Bob")) (pts (Int 25))))) + +(CreateBranch (name "v2")) +#+end_src + +Now jump around and watch the relation change: + +#+begin_src sexp +(Checkout "v0") +(Base scores) +; (0 rows) + +(Checkout "v1") +(Base scores) +; ┌────────┬─────┐ +; │ player │ pts │ +; ├────────┼─────┤ +; │ Alice │ 10 │ +; └────────┴─────┘ + +(Checkout "v2") +(Base scores) +; ┌────────┬─────┐ +; │ player │ pts │ +; ├────────┼─────┤ +; │ Alice │ 10 │ +; │ Bob │ 25 │ +; └────────┴─────┘ +#+end_src + +* Example: diverge and merge + +#+begin_src sexp +(Checkout "master") +(CreateBranch (name "feature")) + +(Checkout "master") +(InsertTuple (relation "users") (attributes ((id (Int 1)) (name (Str "Alice"))))) + +(Checkout "feature") +(InsertTuple (relation "users") (attributes ((id (Int 2)) (name (Str "Bob"))))) + +(Merge (left "master") (right "feature") (strategy PreferLeft)) + +(Checkout "master") +(Base users) +; ┌────┬───────┐ +; │ id │ name │ +; ├────┼───────┤ +; │ 1 │ Alice │ +; │ 2 │ Bob │ +; └────┴───────┘ +#+end_src + +* See also + +- ~lib/dcl/~ — AST, parser, executor +- ~lib/management/branch.ml~ — branch registry and ephemeral relations +- ~lib/management/merge.ml~ — 3-way merge engine +- ~lib/management/diff.ml~ — relation diff used internally by merge diff --git a/docs/icl-quantification.org b/docs/icl-quantification.org new file mode 100644 index 0000000..7a81551 --- /dev/null +++ b/docs/icl-quantification.org @@ -0,0 +1,480 @@ +#+TITLE: ICL Quantification: Runtime Model and Evaluation + +* Overview + +This document describes precisely how ICL constraints are represented, compiled, +and evaluated at runtime. It covers the full stack from the s-expression syntax +through AST compilation, context construction, and recursive evaluation — with +particular attention to the cost model of quantifiers, which is the primary target +for future performance work. + +* Constraint Type (~lib/constraint.ml~) + +The runtime constraint type is an algebraic tree: + +#+begin_src ocaml +type t = + | MemberOf of { target : relation_name; binding : binding } + | Not of { body : t; universe : relation_name } + | And of t list + | Or of t list + | Exists of { variable : attr_name; quantifier : relation_name; body : t } + | Forall of { variable : attr_name; quantifier : relation_name; body : t } +#+end_src + +A ~binding~ is a ~BindingMap~ (a ~Map.Make(String)~) from target attribute names +to ~binding_expr~: + +#+begin_src ocaml +type binding_expr = + | Var of attr_name (* resolved from current tuple at eval time *) + | Const of Conventions.AbstractValue.t (* literal, resolved at compile time *) +#+end_src + +The ~variable~ field in ~Exists~ and ~Forall~ names the bound tuple for use in +~Var~ expressions inside the body. Attributes from the quantifier row are merged +into the evaluation tuple under the prefix ~variable ^ "."~, so ~(Var "d.dept_id")~ +unambiguously refers to the ~dept_id~ attribute of the tuple bound to variable ~"d"~. +See [[*Tuple Extension: ~extend_tuple~][Tuple Extension: extend_tuple]] for the implementation and [[*The Variable Namespacing Problem][The Variable Namespacing Problem]] +for the history of the bug this fixes. + +* Evaluation Context (~eval_context~) + +Evaluation does not access storage or the database directly. It works through an +~eval_context~ record built once per insert operation and closed over a specific +~(storage, db)~ snapshot: + +#+begin_src ocaml +type eval_context = { + check_membership : + relation_name -> + (attr_name * Conventions.AbstractValue.t) list -> + bool; + iterate_finite : + relation_name -> + (attr_name * Conventions.AbstractValue.t) list list option; +} +#+end_src + +Both fields are closures. This indirection decouples ~Constraint.evaluate~ from +the storage backend and allows the same constraint tree to be evaluated against +different snapshots. + +** ~check_membership~ + +Built in ~Manipulation.Make.build_eval_context~. Given a relation name and a list +of ~(attr_name, value)~ pairs, it returns ~true~ iff a tuple exists in the named +relation whose attributes match every pair in the list. + +The implementation: +1. Looks up the relation in the ~db~ snapshot. +2. Constructs a synthetic ~Tuple.Materialized~ from the bound pairs and runs + ~rel.membership_criteria~ against it. If it fails, returns ~false~ immediately. +3. If the relation has no Merkle tree (ephemeral/generator relation), + ~membership_criteria~ alone is trusted and the function returns ~true~. +4. If the relation has a tree, it calls ~Merkle.keys tree~ to obtain *all* tuple + hashes, then linearly scans them. For each hash it: + a. Loads the raw bytes from storage (~Storage.load_raw~). + b. Deserialises the ~Storable.Tuple.t~ to get the attribute hash list. + c. For each bound pair ~(bk, bv)~, finds the matching attribute by name, loads + its value bytes from storage (~Storage.load_raw~ again), unmarshals it, and + compares with ~Stdlib.(=)~. + d. Short-circuits to ~true~ on the first tuple that satisfies all pairs. + e. Returns ~false~ if no tuple matches. + +The cost of a single ~check_membership~ call on a relation of cardinality /n/ with +/a/ bound attributes and average /k/ attributes per stored tuple is: + + O(n · (1 + a · k)) storage round-trips in the worst case. + +No indexes exist. Every check is a full table scan at the storage level. + +** ~iterate_finite~ + +Given a relation name, returns ~Some rows~ where ~rows~ is a fully materialised +list of rows, each a ~(attr_name * AbstractValue.t) list~. Returns ~None~ if the +relation has infinite or unconstrained cardinality +(~AlephZero~ or ~Continuum~ in ~Conventions.Cardinality~). + +Only relations with cardinality ~Finite _~ or ~ConstrainedFinite~ are iterable. +Generator-based relations with no tree return ~Some []~. + +The materialisation path: +1. ~Merkle.keys tree~ — loads all tuple hashes. +2. For each hash: ~Storage.load_raw~ → ~Storable.Tuple.of_bytes~ → attribute hash list. +3. For each attribute hash: ~Storage.load_raw~ → ~Marshal.from_bytes~. + +This eagerly materialises the *entire* quantifier relation into memory before +evaluation begins. For a relation of cardinality /n/ with /k/ attributes each, +the cost is O(n · k) storage loads and the full result occupies O(n · k) memory. + +* Variable Resolution: ~bind~ + +Before a ~MemberOf~ check is executed, the binding map is resolved against the +current tuple via ~bind~: + +#+begin_src ocaml +let bind (b : binding) (tuple : Tuple.materialized) + : (attr_name * Conventions.AbstractValue.t) list = + BindingMap.fold + (fun target_attr expr acc -> + let value = match expr with + | Const v -> Some v + | Var src_attr -> + match Tuple.AttributeMap.find_opt src_attr tuple.attributes with + | Some attr -> Some attr.Attribute.value + | None -> None + in + match value with + | Some v -> (target_attr, v) :: acc + | None -> acc) + b [] +#+end_src + +Key behaviour: +- ~Const v~ is lifted directly; no attribute lookup. +- ~Var src_attr~ looks up ~src_attr~ in ~tuple.attributes~. If the attribute is + absent, the pair is *silently dropped* from the bound list. A ~MemberOf~ with + incomplete bindings may match unintended tuples or always pass if the target + relation contains tuples with fewer attributes. +- The result is a plain assoc list, not a map; duplicate keys are possible if + the binding contains both a ~Const~ and a ~Var~ targeting the same name. + +* Tuple Extension: ~extend_tuple~ + +When a quantifier (~Exists~ or ~Forall~) iterates over a row, it extends the +current evaluation tuple by merging that row's attributes in: + +#+begin_src ocaml +and extend_tuple (tuple : Tuple.materialized) + (variable : attr_name) + (row : (attr_name * Conventions.AbstractValue.t) list) + : Tuple.materialized = + let extra_attrs = + List.fold_left + (fun acc (k, v) -> + Tuple.AttributeMap.add (variable ^ "." ^ k) { Attribute.value = v } acc) + tuple.attributes row + in + { tuple with attributes = extra_attrs } +#+end_src + +Two important facts: + +1. *Quantifier attributes are namespaced by the variable name.* Each attribute ~k~ + from the quantifier row is inserted as ~variable ^ "." ^ k~. The incoming tuple's + own attributes are never overwritten. ~(Var "dept_id")~ resolves to the base + tuple's value; ~(Var "d.dept_id")~ resolves to the value contributed by the + quantifier bound to ~"d"~. See [[*The Variable Namespacing Problem][The Variable Namespacing Problem]] for the + earlier behaviour where ~variable~ was ignored and overwrites were silent. + +2. *A new ~AttributeMap~ is allocated on every extend call.* With /a/ existing + attributes and /r/ new attributes from the row, ~fold_left~ performs /r/ + ~AttributeMap.add~ operations each building on the previous map. For /q/ + nested quantifiers of cardinalities /n₁, n₂, ..., nq/, ~extend_tuple~ is + called /n₁ · n₂ · ... · nq/ times total — once per combination. + +* Recursive Evaluation: ~evaluate~ + +#+begin_src ocaml +let rec evaluate (ctx : eval_context) (tuple : Tuple.materialized) (c : t) + : (bool, diagnostic) result = +#+end_src + +The function is structurally recursive over the constraint tree. Each case: + +** ~MemberOf~ + +#+begin_src ocaml +| MemberOf { target; binding } -> + let bound_values = bind binding tuple in + if ctx.check_membership target bound_values then Ok true + else Error (MembershipFailed { target; bound_values }) +#+end_src + +Resolves bindings from the current tuple (O(|binding|) attribute lookups), then +delegates to ~check_membership~. Returns ~Ok true~ or ~Error~ (never ~Ok false~) +— the ~Ok false~ branch of ~Exists~/~Forall~ is distinguished from ~Error~. + +** ~Not~ + +#+begin_src ocaml +| Not { body; universe = _ } -> + match evaluate ctx tuple body with + | Ok true -> Ok false + | Ok false -> Ok true + | Error (MembershipFailed _) -> Ok true + | Error d -> Error d +#+end_src + +~MembershipFailed~ from the body is treated as ~Ok true~ (negation of a failed +membership = the tuple is not a member = negation succeeds). The ~universe~ field +is a declarative annotation for closed-world reasoning and is not used at runtime. + +** ~And~ / ~Or~ + +Both use short-circuit evaluation: +- ~And~: stops at the first ~Ok false~ or ~Error~. +- ~Or~: stops at the first ~Ok true~; swallows ~Error~ branches and continues. + +Neither produces diagnostics for the other branches once a decision is reached. +Note that ~evaluate_named~ (which evaluates all named constraints on a tuple) does +*not* short-circuit — it collects all failures before returning. + +** ~Exists~ + +#+begin_src ocaml +| Exists { variable; quantifier; body } -> + match ctx.iterate_finite quantifier with + | None -> Error (UnboundedQuantifier { variable; quantifier }) + | Some rows -> + let rec check = function + | [] -> Ok false + | row :: rest -> + let extended_tuple = extend_tuple tuple variable row in + match evaluate ctx extended_tuple body with + | Ok true -> Ok true + | Ok false -> check rest + | Error _ -> check rest + in + check rows +#+end_src + +The execution model: +1. ~iterate_finite~ is called, fully materialising the quantifier relation. +2. Rows are iterated sequentially. For each row, ~extend_tuple~ merges it into + the current tuple, and ~evaluate~ recurses into the body. +3. The first ~Ok true~ short-circuits: remaining rows are not evaluated. +4. Both ~Ok false~ and ~Error~ from the body are treated identically — the row is + skipped and iteration continues. *Errors inside the body of an ~Exists~ are + silently discarded.* +5. If all rows are exhausted without ~Ok true~, returns ~Ok false~. + +An ~Exists~ over a relation of cardinality /n/ with a body whose evaluation cost +is /C/ has worst-case cost O(n · C). Nesting two ~Exists~ quantifiers over +relations of cardinalities /n/ and /m/ has worst-case cost O(n · m · C). +In general, /q/ nested quantifiers produce O(∏ nᵢ · C) body evaluations — a +Cartesian product. + +** ~Forall~ + +#+begin_src ocaml +| Forall { variable; quantifier; body } -> + match ctx.iterate_finite quantifier with + | None -> Error (UnboundedQuantifier { variable; quantifier }) + | Some rows -> + let rec check = function + | [] -> Ok true + | row :: rest -> + let extended_tuple = extend_tuple tuple variable row in + match evaluate ctx extended_tuple body with + | Ok true -> check rest + | Ok false -> Ok false + | Error (MembershipFailed _) -> Ok false + | Error d -> Error d + in + check rows +#+end_src + +Symmetric to ~Exists~ but short-circuits on ~Ok false~ or ~MembershipFailed~. +Unlike ~Exists~, other ~Error~ variants (e.g., ~UnboundedQuantifier~) are +propagated rather than silently consumed. The cost model is identical: O(∏ nᵢ · C). + +* The Variable Namespacing Problem + +This section documents the original bug and explains why the current implementation +is correct. In the initial implementation, ~extend_tuple~ took ~variable~ as +~_variable~ — a named-but-discarded argument — and merged quantifier row attributes +flat into the tuple under their original names. This had two consequences. + +** Attribute Shadowing (fixed) + +If the incoming tuple and the quantifier row shared an attribute name, the +quantifier's value won silently. Concretely: an Employee with ~dept_id=99~ being +checked by an ~Exists~ over Department rows would have its ~dept_id~ overwritten +by each Department row's ~dept_id~ in turn. ~(Var "dept_id")~ in the body then +resolved to the Department's own id, not the Employee's. An FK constraint written +as ~(MemberOf (target "Department") (binding ((dept_id (Var "dept_id")))))~ inside +an ~Exists~ over Department would always pass — it was validating the Department +against itself rather than checking whether the Employee's ~dept_id~ existed. + +** Multi-Quantifier Ambiguity (fixed) + +With two nested quantifiers over relations sharing attribute names, the inner +quantifier's pass through ~extend_tuple~ overwrote what the outer one had written. +There was no way to write a body that simultaneously referred to attributes from +two distinct quantifier rows of the same name. + +** Resolution + +Both problems are resolved by namespacing: each attribute ~k~ from the quantifier +row is stored as ~variable ^ "." ^ k~. The base tuple is never modified. The +~variable~ argument, previously discarded as ~_variable~, is now the namespace +prefix. The fix is in ~lib/constraint.ml~ with an inline TODO describing the +deeper issue of tuple-level provenance as a structural solution. + +* N-Ary Quantification + +The current AST represents each quantifier as a single ~(variable, quantifier)~ +pair. N-ary constraints across three or more relations require nesting: + +#+begin_src lisp +(Exists (variable "b") (quantifier "Building") + (Exists (variable "r") (quantifier "Room") + (Exists (variable "s") (quantifier "Suite") + ...))) +#+end_src + +This is semantically correct once namespacing is in place, but verbose and implies +a strict left-to-right evaluation order with no opportunity for reordering. + +The proposed n-ary form makes the binding list first-class: + +#+begin_src lisp +(Exists + (bindings ((b "Building") (r "Room") (s "Suite"))) + (body ...)) +#+end_src + +The executor folds over the binding list left-to-right, extending the tuple at +each step — equivalent to nested ~Exists~ but expressed as a single node: + +#+begin_src ocaml +| Exists { bindings; body } -> + let rec go bindings tuple = + match bindings with + | [] -> evaluate ctx tuple body + | (variable, quantifier) :: rest -> + match ctx.iterate_finite quantifier with + | None -> Error (UnboundedQuantifier { variable; quantifier }) + | Some rows -> + let rec check = function + | [] -> Ok false + | row :: rest' -> + let extended = extend_tuple tuple variable row in + match go rest extended with + | Ok true -> Ok true + | Ok false | Error _ -> check rest' + in + check rows + in + go bindings tuple +#+end_src + +The cost remains O(∏ nᵢ · C) — the n-ary form does not change the complexity, +but it makes the binding structure explicit and opens the door to reordering +optimisations (e.g., evaluate the smallest relation first). + +* Performance Inventory + +The following is a precise account of known costs and inefficiencies, intended +as a reference for future optimisation work. + +** Eager Full Materialisation of Quantifier Relations + +~iterate_finite~ loads every tuple in the quantifier relation from storage before +the first body evaluation begins. For a ~Forall~ whose first body call returns +~Ok false~, all subsequent tuples were loaded needlessly. A streaming/lazy +iterator would allow early termination before full materialisation. + +** Linear Scan in ~check_membership~ + +Every ~MemberOf~ check performs a full linear scan over all tuple hashes in the +target relation's Merkle tree. There are no secondary indexes. For a relation of +cardinality /n/: + +- /n/ calls to ~Storage.load_raw~ to fetch stored tuples. +- For each tuple, up to /a/ additional ~Storage.load_raw~ calls to fetch + attribute values. +- Comparison via structural equality (~Stdlib.(=)~) on unmarshalled ~Obj.t~ values. + +An index mapping ~(relation_name, attr_name, value_hash)~ to tuple hashes would +reduce this to O(log n) or O(1) per ~MemberOf~ check. + +** AttributeMap Allocation per ~extend_tuple~ Call + +~extend_tuple~ allocates a new ~AttributeMap~ on every invocation by folding over +the row into the existing map. For nested quantifiers of cardinalities +/n₁ × n₂ × ... × nq/, this allocates ∏ nᵢ maps during a single constraint check. +A persistent/functional map amortises this somewhat (structural sharing), but +each call still produces a new root node. + +A flat association list or array, indexed by a fixed schema, would be cheaper +for extend and lookup at the cost of schema rigidity. + +** Redundant Storage Loads Across Constraints + +The ~eval_context~ is built once per ~create_tuple~ call, but it is not a cache — +every ~check_membership~ and ~iterate_finite~ call re-reads from storage. If a +relation is referenced in multiple constraints or multiple ~MemberOf~ nodes within +one constraint tree, its tuples are loaded multiple times. + +A constraint-session cache (a ~Hashtbl~ from relation_name to materialised rows, +populated lazily on first access) would eliminate redundant loads within a single +tuple insertion. + +** No Short-Circuit Across Named Constraints + +~evaluate_named~ evaluates every constraint in the named list, collecting all +failures before returning: + +#+begin_src ocaml +let failures = + List.filter_map + (fun (name, c) -> + match evaluate ctx tuple c with + | Ok true -> None + | Ok false -> Some (name, ...) + | Error d -> Some (name, d)) + named +in +#+end_src + +For a tuple that violates the first constraint, all remaining constraints are +still evaluated at full cost. Short-circuiting on first failure is correct when +complete diagnostics are not required (e.g., interactive insertion). A lazy stream +of failures, computed on demand, would support both use cases. + +** Cartesian Product Complexity of Nested Quantifiers + +For /q/ nested ~Exists~/~Forall~ quantifiers over relations of cardinalities +/n₁, n₂, ..., nq/ with body cost /C/: + + Worst-case body evaluations = n₁ × n₂ × ... × nq + + Worst-case storage loads = (∑ nᵢ · kᵢ) + n₁ · n₂ · ... · nq · C_membership + +Where /kᵢ/ is the attribute count of relation /i/ and /C_membership/ is the cost +of ~check_membership~ on the body's target relation. + +Mitigations: +- *Evaluate smallest relation first* (selectivity-based reordering): reduces the + Cartesian product by pruning earlier. +- *Push ~MemberOf~ filters into the iteration*: instead of iterating all rows of + the quantifier relation and then checking membership, filter the quantifier rows + during iteration using the same index that would accelerate ~check_membership~. +- *Semi-join reduction*: for FK-style constraints, a single hash lookup suffices + and no Cartesian product is needed. + +* Summary of Call Chain for a Single Tuple Insertion + +#+begin_example +create_tuple + └── build_eval_context (storage, db) [once per insertion] + └── evaluate_named ctx tuple named_constraints [once per insertion] + └── evaluate ctx tuple c [once per named constraint] + ├── Exists / Forall + │ └── iterate_finite quantifier [materialises full relation] + │ ├── Merkle.keys tree + │ └── Storage.load_raw × (n × k) + │ └── for each row: + │ ├── extend_tuple [allocates new AttributeMap] + │ └── evaluate ctx extended_tuple body + │ └── MemberOf + │ ├── bind [resolves Vars from extended tuple] + │ └── check_membership target bound_values + │ ├── Merkle.keys tree + │ └── Storage.load_raw × (n' × (1 + a)) + └── And / Or / Not + └── evaluate (recursive) +#+end_example diff --git a/docs/icl.org b/docs/icl.org new file mode 100644 index 0000000..c2258bf --- /dev/null +++ b/docs/icl.org @@ -0,0 +1,108 @@ +#+TITLE: ICL — Integrity Control Language + +ICL registers integrity constraints on relations. A constraint is a +membership check: before any tuple is inserted, Sakura verifies that +the tuple belongs to every constraint-relation attached to the target +relation. + +Constraints are expressed as S-expressions and sent over the wire like +any other command. + +* Syntax + +#+begin_src +(RegisterConstraint + (constraint_name "") + (relation_name "") + (body )) +#+end_src + +A ~~ is one of: + +| Form | Meaning | +|-------------------------------------------------+--------------------------------| +| ~(MemberOf (target R) (binding (...)))~ | Tuple must be in relation R | +| ~(Not (body B) (universe R))~ | Negation (closed-world over R) | +| ~(And (B1 B2 ...))~ | All must hold | +| ~(Or (B1 B2 ...))~ | At least one must hold | +| ~(Exists (variable v) (quantifier R) (body B))~ | ∃ v ∈ R such that B holds | +| ~(Forall (variable v) (quantifier R) (body B))~ | ∀ v ∈ R, B holds | + +Bindings map target-relation attribute names to values drawn from the +tuple being checked: + +| Binding expr | Meaning | +|---------------------+--------------------------------| +| ~(Var "attr")~ | Value of ~attr~ from the tuple | +| ~(Const (Int N))~ | Literal integer N | +| ~(Const (Str "s"))~ | Literal string s | +| ~(Const (Float f))~ | Literal float f | + +* Examples + +** Foreign key + +#+begin_src sexp +(CreateRelation (name "Department") (schema ((dept_id "integer") (dept_name "string")))) +(CreateRelation (name "Employee") (schema ((emp_id "integer") (emp_name "string") (dept_id "integer")))) + +(RegisterConstraint + (constraint_name "fk_employee_dept") + (relation_name "Employee") + (body (MemberOf + (target "Department") + (binding ((dept_id (Var "dept_id"))))))) +#+end_src + +** Range check + +#+begin_src sexp +(CreateRelation (name "Result") (schema ((student_id "integer") (score "integer")))) + +(RegisterConstraint + (constraint_name "score_range") + (relation_name "Result") + (body (And + ((MemberOf (target "greater_than_or_equal_natural") + (binding ((left (Var "score")) (right (Const (Int 0)))))) + (MemberOf (target "less_than_or_equal_natural") + (binding ((left (Var "score")) (right (Const (Int 100)))))))))) +#+end_src + +** Existential (FK through a join) + +A ~Suite~ is only valid if its room belongs to a building with more +than 3 floors: + +#+begin_src sexp +(CreateRelation (name "Building") (schema ((building_id "integer") (building_name "string") (floors "integer")))) +(CreateRelation (name "Room") (schema ((room_id "integer") (building_id "integer") (floor "integer")))) +(CreateRelation (name "Suite") (schema ((suite_id "integer") (room_id "integer") (suite_name "string")))) + +(RegisterConstraint + (constraint_name "suite_in_tall_building") + (relation_name "Suite") + (body + (Exists (variable "r") (quantifier "Room") + (body + (Exists (variable "b") (quantifier "Building") + (body + (And + ((MemberOf (target "Room") + (binding ((room_id (Var "room_id"))))) + (MemberOf (target "Building") + (binding ((building_id (Var "r.building_id"))))) + (MemberOf (target "greater_than_natural") + (binding ((left (Var "b.floors")) + (right (Const (Int 3)))))))))))))) +#+end_src + +Note: quantifier variables are namespaced — attributes from variable +~r~ are accessed as ~r.attr_name~ inside nested scopes. + +* See also + +- ~lib/icl/~ — AST, parser, executor +- ~lib/constraint.ml~ — runtime constraint representation and evaluator +- ~docs/icl-quantification.org~ — full runtime model for ~Exists~/~Forall~ +- ~docs/constraints.org~ — conceptual background diff --git a/docs/karuta-integration.org b/docs/karuta-integration.org index a144a25..0642254 100644 --- a/docs/karuta-integration.org +++ b/docs/karuta-integration.org @@ -14,10 +14,26 @@ Here's an overview of the sublanguages and how they are manifested in Karuta: - Pure querying, total/terminating subset; - No user recursion with no self references. -** DCL (Data Constraint Language) +** ICL (Integrity Control Language) - Integrity rules (key, FK-like, checks, assertions, aggregates-for-integrity). - Semantically predicates, but with enforcement timing (on write/commit), not free query operators. +- Implemented in =lib/icl/= (=Ast=, =Parser=, =Executor=). + +** DCL (Database Control Language) + +- Branch management: create/checkout branches, query HEAD and tip hashes. +- Merge: 3-way merge of two branch tips with configurable conflict strategy (=PreferLeft=, =PreferRight=, =RevertToAncestor=). +- Implemented in =lib/dcl/= (=Ast=, =Parser=, =Executor=). +- Example commands: + #+begin_src sexp + (CreateBranch (name "feature") (tip "")) + (Checkout "feature") + (GetHead) + (GetBranchTip "main") + (UpdateBranchTip (name "main") (tip "")) + (Merge (left "main") (right "feature") (strategy PreferLeft)) + #+end_src ** DML (Data Manipulation Language) @@ -35,7 +51,7 @@ Here's an overview of the sublanguages and how they are manifested in Karuta: ** PPL (Procedural Predicate Language) - Stored procedures/functions, recursion allowed, orchestration logic. -- Can call DRL/DML/DCL-aware operations, but not all PPL predicates are DRL-safe. +- Can call DRL/DML/ICL/DCL-aware operations, but not all PPL predicates are DRL-safe. ** ACL (Authorization/Policy Language) (optional early, important later) @@ -62,21 +78,21 @@ Here's an overview of the sublanguages and how they are manifested in Karuta: person[string, natural] :: sakura:persisted person[Name, Age] :- valid_age[Age]. - % DCL + % ICL another-constraint[list[person], string, natural] :: sakura:constraint another-constraint[[], _, _]. another-constraint[[person[Name, Age]|Rest], Whatever1, Whatever2] :- (eq[Name, Whatever1] ; !eq[Name, Whatever1], !eq[Age, Whatever2]), another-constraint[Rest, Whatever1, Whatever2]. - % DCL + % ICL my-predicate[int, string, nat] :: sakura:constraint my-predicate[Arg1, Arg2, Arg3] :- another-module:my-predicate[Arg1, Arg2, Arg3], on[insert, update], timing[immediate]. - % DCL + % ICL valid_age/1 :: sakura:constraint valid_age[Age] with [karuta, sakura] :- nat[Age], diff --git a/docs/n-way-binding.org b/docs/n-way-binding.org index 39c9d65..85dc0e3 100644 --- a/docs/n-way-binding.org +++ b/docs/n-way-binding.org @@ -1,9 +1,9 @@ -#+TITLE: N-Way Binding in DCL Constraints +#+TITLE: N-Way Binding in ICL Constraints #+DATE: 2026-03-11 * Overview -The DCL constraint language supports quantified membership checks via ~Exists~ and ~Forall~. +The ICL constraint language supports quantified membership checks via ~Exists~ and ~Forall~. This document illustrates the hotel/building/room/suite example to motivate n-ary quantification and show how 3-wise (and deeper) relational composition is expressed. @@ -72,7 +72,7 @@ to fire when suites referencing its rooms are inserted. ((suite_id (Int 1003)) (room_id (Int 102)) (suite_name (Str "Deluxe")) (capacity (Int 3)))))) #+end_src -* DCL — Constraints +* ICL — Constraints Binary FK constraints compose to enforce referential integrity along the chain ~Suite → Room → Building~. Each link is declared independently. @@ -202,5 +202,5 @@ bound to variable ~x~. Without namespacing, ~extend_tuple~ would overwrite the incoming tuple's attributes with same-named attributes from the quantifier row, silently making ~Var~ resolve to -the wrong scope. See ~lib/constraint.ml~ and ~docs/dcl-quantification.org~ for a full +the wrong scope. See ~lib/constraint.ml~ and ~docs/icl-quantification.org~ for a full account of this failure mode and the provenance TODO. diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml index 95e0271..e1dae13 100644 --- a/lib/dcl/ast.ml +++ b/lib/dcl/ast.ml @@ -1,23 +1,13 @@ open Sexplib.Std -type binding_expr = - | Var of string - | Const of Drl.Ast.value (** reuse DRL value for literals *) -[@@deriving sexp] - -type constraint_body = - | 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 } +type merge_strategy = PreferLeft | PreferRight | RevertToAncestor [@@deriving sexp] type statement = - | RegisterConstraint of { - constraint_name: string; - relation_name: string; - body: constraint_body; - } + | 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 } [@@deriving sexp] diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml index 810781f..bf549ec 100644 --- a/lib/dcl/executor.ml +++ b/lib/dcl/executor.ml @@ -1,54 +1,94 @@ -module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) +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) type error = - | ManipulationError of Manipulation.error - | ConversionError of string - - let wrap_manip = Result.map_error (fun e -> ManipulationError e) - - (** Convert a DCL binding_expr to a runtime Constraint.binding_expr *) - let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function - | Ast.Var name -> Constraint.Var name - | Ast.Const value -> Constraint.Const (Drl.Ast.value_to_abstract value) - - (** Convert a list of (target_attr, binding_expr) pairs to a Constraint.binding (BindingMap) *) - let convert_binding (pairs : (string * Ast.binding_expr) list) : Constraint.binding = - List.fold_left - (fun acc (key, expr) -> - Constraint.BindingMap.add key (convert_binding_expr expr) acc) - Constraint.BindingMap.empty - pairs - - (** Convert a DCL constraint_body AST to a runtime Constraint.t *) - let rec convert_body : Ast.constraint_body -> Constraint.t = function - | Ast.MemberOf { target; binding } -> - Constraint.MemberOf { target; binding = convert_binding binding } - | Ast.Not { body; universe } -> - Constraint.Not { body = convert_body body; universe } - | Ast.And bodies -> - Constraint.And (List.map convert_body bodies) - | Ast.Or bodies -> - Constraint.Or (List.map convert_body bodies) - | Ast.Exists { variable; quantifier; body } -> - Constraint.Exists { variable; quantifier; body = convert_body body } - | Ast.Forall { variable; quantifier; body } -> - Constraint.Forall { variable; quantifier; body = convert_body body } + | BranchError of string + | MergeError of string + + 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 manip_err = function + | Manipulation.RelationNotFound s -> "RelationNotFound: " ^ s + | Manipulation.RelationAlreadyExists s -> "RelationAlreadyExists: " ^ s + | Manipulation.TupleNotFound h -> "TupleNotFound: " ^ h + | Manipulation.DuplicateTuple h -> "DuplicateTuple: " ^ h + | Manipulation.ConstraintViolation s -> "ConstraintViolation: " ^ s + | Manipulation.StorageError s -> "StorageError: " ^ s let execute (storage : Storage.t) (db : Management.Database.t) (stmt : Ast.statement) - : (Management.Database.t, error) result = + : (Management.Database.t * string, error) result = match stmt with - | Ast.RegisterConstraint { constraint_name; relation_name; body } -> - (* TODO: Additional constraint operations (drop constraint, list constraints, - validate existing tuples against new constraint) are not supported via DCL. - Use the OCaml API for these advanced operations. *) - let runtime_body = convert_body body in - Ops.register_constraint storage db - ~constraint_name ~relation_name ~body:runtime_body - |> wrap_manip + + | 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 (manip_err 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 (manip_err 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) diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml index a7981c0..3caf748 100644 --- a/lib/dcl/parser.ml +++ b/lib/dcl/parser.ml @@ -1,7 +1,13 @@ type error = ParseError of string let of_string s = - match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with + (* ppx_sexp_conv encodes no-argument variants as bare atoms, so + unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *) + let sexp = match Sexplib.Sexp.of_string s with + | Sexplib.Sexp.List [atom] -> atom + | other -> other + in + match Ast.statement_of_sexp sexp with | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml new file mode 100644 index 0000000..95e0271 --- /dev/null +++ b/lib/icl/ast.ml @@ -0,0 +1,23 @@ +open Sexplib.Std + +type binding_expr = + | Var of string + | Const of Drl.Ast.value (** reuse DRL value for literals *) +[@@deriving sexp] + +type constraint_body = + | 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 } +[@@deriving sexp] + +type statement = + | RegisterConstraint of { + constraint_name: string; + relation_name: string; + body: constraint_body; + } +[@@deriving sexp] diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml new file mode 100644 index 0000000..a895135 --- /dev/null +++ b/lib/icl/executor.ml @@ -0,0 +1,50 @@ +module Make (Storage : Management.Physical.S) = struct + module Ops = Manipulation.Make(Storage) + + type error = + | ManipulationError of Manipulation.error + | ConversionError of string + + let wrap_manip = Result.map_error (fun e -> ManipulationError e) + + let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function + | Ast.Var name -> Constraint.Var name + | Ast.Const value -> Constraint.Const (Drl.Ast.value_to_abstract value) + + let convert_binding (pairs : (string * Ast.binding_expr) list) : Constraint.binding = + List.fold_left + (fun acc (key, expr) -> + Constraint.BindingMap.add key (convert_binding_expr expr) acc) + Constraint.BindingMap.empty + pairs + + let rec convert_body : Ast.constraint_body -> Constraint.t = function + | Ast.MemberOf { target; binding } -> + Constraint.MemberOf { target; binding = convert_binding binding } + | Ast.Not { body; universe } -> + Constraint.Not { body = convert_body body; universe } + | Ast.And bodies -> + Constraint.And (List.map convert_body bodies) + | Ast.Or bodies -> + Constraint.Or (List.map convert_body bodies) + | Ast.Exists { variable; quantifier; body } -> + Constraint.Exists { variable; quantifier; body = convert_body body } + | Ast.Forall { variable; quantifier; body } -> + Constraint.Forall { variable; quantifier; body = convert_body body } + + let execute + (storage : Storage.t) + (db : Management.Database.t) + (stmt : Ast.statement) + : (Management.Database.t * string, error) result = + match stmt with + | Ast.RegisterConstraint { constraint_name; relation_name; body } -> + let runtime_body = convert_body body in + (match Ops.register_constraint storage db + ~constraint_name ~relation_name ~body:runtime_body + |> wrap_manip with + | Ok new_db -> Ok (new_db, "Constraint registered: " ^ constraint_name) + | Error e -> Error e) +end + +module Memory = Make(Management.Physical.Memory) diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml new file mode 100644 index 0000000..a7981c0 --- /dev/null +++ b/lib/icl/parser.ml @@ -0,0 +1,9 @@ +type error = ParseError of string + +let of_string s = + match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with + | stmt -> Ok stmt + | exception exn -> Error (ParseError (Printexc.to_string exn)) + +let to_string stmt = + Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/management/branch.ml b/lib/management/branch.ml new file mode 100644 index 0000000..70dfd85 --- /dev/null +++ b/lib/management/branch.ml @@ -0,0 +1,138 @@ +(** Branch registry: named pointers to database tip hashes, plus HEAD tracking. + Stored in the Physical backend under reserved key prefixes: + - "branch:" → serialized { name; tip } + - "branch_names" → serialized string list (index for enumeration) + - "head" → branch name as raw bytes *) + +type t = { + name : string; + tip : Conventions.Hash.t; +} + +type head = string + +type error = string + +let branch_key name = "branch:" ^ name +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) + | _ -> [] + + let store_names storage names = + let bytes = Marshal.to_bytes names [] in + ignore (Storage.store_raw storage names_key bytes) + + 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 ()) + + let checkout storage branch_name = + let bytes = Bytes.of_string branch_name in + Storage.store_raw storage head_key bytes + + let get_head storage = + match Storage.load_raw storage head_key with + | Ok (Some bytes) -> Ok (Some (Bytes.to_string bytes)) + | Ok None -> Ok None + | Error e -> Error e + + 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) + | 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 + | 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 + Ok branches + + let branch_relation storage : Relation.t = + let schema = + Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string" + in + let mk v = { Attribute.value = Obj.repr v } in + 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 )) + in + Relation.make ~hash:None ~name:Prelude.Catalog.branch_rel_name ~schema + ~tree:None ~constraints:None + ~cardinality:Conventions.Cardinality.ConstrainedFinite + ~generator:(Some generator) + ~membership_criteria:(fun _ -> true) + ~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name) + ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) + + let head_relation storage : Relation.t = + let schema = Schema.empty |> Schema.add "branch" "string" in + let mk v = { Attribute.value = Obj.repr v } in + 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 _ -> Generator.Done + in + Relation.make ~hash:None ~name:Prelude.Catalog.head_rel_name ~schema + ~tree:None ~constraints:None + ~cardinality:Conventions.Cardinality.ConstrainedFinite + ~generator:(Some generator) + ~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/diff.ml b/lib/management/diff.ml new file mode 100644 index 0000000..865c757 --- /dev/null +++ b/lib/management/diff.ml @@ -0,0 +1,60 @@ +(** Structural delta between two Database.t states. + Computes what changed from ancestor → target at the relation level. *) + +type relation_diff = + | RelationAdded of Relation.t + | RelationRemoved of string + | RelationModified of { + name : string; + added_tuples : Conventions.Hash.t list; + removed_tuples : Conventions.Hash.t list; + schema_changed : bool; + } + +type t = { + ancestor : Conventions.Hash.t; + left : Conventions.Hash.t; + right : Conventions.Hash.t; + relation_diffs : relation_diff list; +} + +module StringSet = Set.Make(String) + +let relation_keys rel = + match rel.Relation.tree with + | None -> StringSet.empty + | Some tree -> StringSet.of_list (Merkle.keys tree) + +(** Compute relation-level diffs from ancestor → target. *) +let diff ~ancestor ~(target : Database.t) = + let ancestor_names = + Database.get_relation_names ancestor |> StringSet.of_list + in + let target_names = + Database.get_relation_names target |> StringSet.of_list + in + let all_names = StringSet.union ancestor_names target_names in + StringSet.fold (fun name acc -> + let in_ancestor = StringSet.mem name ancestor_names in + let in_target = StringSet.mem name target_names in + match in_ancestor, in_target with + | false, true -> + let rel = Option.get (Database.get_relation target name) in + RelationAdded rel :: acc + | true, false -> + RelationRemoved name :: acc + | true, true -> + let anc_rel = Option.get (Database.get_relation ancestor name) in + let tgt_rel = Option.get (Database.get_relation target name) in + (* Compare hashes — if identical, no diff *) + if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc + else begin + let anc_keys = relation_keys anc_rel in + let tgt_keys = relation_keys tgt_rel in + let added_tuples = StringSet.diff tgt_keys anc_keys |> StringSet.elements in + let removed_tuples = StringSet.diff anc_keys tgt_keys |> StringSet.elements in + let schema_changed = anc_rel.Relation.schema <> tgt_rel.Relation.schema in + RelationModified { name; added_tuples; removed_tuples; schema_changed } :: acc + end + | false, false -> acc (* impossible *) + ) all_names [] diff --git a/lib/management/merge.ml b/lib/management/merge.ml new file mode 100644 index 0000000..e50d0e6 --- /dev/null +++ b/lib/management/merge.ml @@ -0,0 +1,235 @@ +(** 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 + | ConstraintConflict of string + +type strategy = PreferLeft | PreferRight | RevertToAncestor + +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 store_database : storage -> Database.t -> (unit, error) result +end + +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 + 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. *) +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 + { 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)) + +module Make + (Storage : Physical.S) + (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, + lookup for right diffs by relation name, start from ancestor and + apply all the diffs, apply first the left diffs, then right-only diffs + (relations only right touched). If there are no conflicts, persist the + merged database, otherwise return Failed, unless a strategy resolved them. *) + let merge ~storage ~strategy ~left_tip ~right_tip = + 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 + +end diff --git a/lib/manipulation.ml b/lib/manipulation.ml index 2a43b6c..73607fa 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -44,6 +44,8 @@ let build_membership_criteria _schema : (Tuple.t -> bool) = (** Functor to create manipulation operations with a storage backend *) module Make (Storage : Management.Physical.S) = struct type storage = Storage.t + type nonrec error = error + let of_string_error s = StorageError s (* Constraint evaluation context *) diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml index a277066..4a7241a 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -15,6 +15,8 @@ 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 catalog_relation_names = [ relation_rel_name @@ -111,3 +113,4 @@ let build_timing_tuple timing : Tuple.materialized = Tuple.AttributeMap.singleton "timing" { Attribute.value = Obj.magic timing } } + diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml index 6bb1eed..2b902e1 100644 --- a/test/test_relational_engine.ml +++ b/test/test_relational_engine.ml @@ -1630,7 +1630,7 @@ let%test_unit "constraint: evaluate Exists over finite relation" = let b = Constraint.BindingMap.empty |> Constraint.BindingMap.add "left" (Constraint.Var "x") - |> Constraint.BindingMap.add "right" (Constraint.Var "value") + |> Constraint.BindingMap.add "right" (Constraint.Var "value.value") in let c = Constraint.Exists @@ -1674,7 +1674,7 @@ let%test_unit "constraint: evaluate Forall fails when not all match" = let b = Constraint.BindingMap.empty |> Constraint.BindingMap.add "left" (Constraint.Var "x") - |> Constraint.BindingMap.add "right" (Constraint.Var "value") + |> Constraint.BindingMap.add "right" (Constraint.Var "value.value") in let c = Constraint.Forall @@ -2583,41 +2583,41 @@ let%test_unit "dml: insert into nonexistent relation returns error" = ============================================================================ *) let%test_unit "dcl: round-trip RegisterConstraint MemberOf" = - let src = Dcl.Ast.RegisterConstraint { + let src = Icl.Ast.RegisterConstraint { constraint_name = "fk_order"; relation_name = "order_items"; - body = Dcl.Ast.MemberOf { target = "orders"; binding = [("order_id", Dcl.Ast.Var "order_id")] } + body = Icl.Ast.MemberOf { target = "orders"; binding = [("order_id", Icl.Ast.Var "order_id")] } } in - match Dcl.Parser.of_string (Dcl.Parser.to_string src) with + 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 = Dcl.Ast.RegisterConstraint { + let src = Icl.Ast.RegisterConstraint { constraint_name = "valid_range"; relation_name = "scores"; - body = Dcl.Ast.And [ - Dcl.Ast.MemberOf { target = "ge_zero"; - binding = [("left", Dcl.Ast.Var "score"); ("right", Dcl.Ast.Const (Drl.Ast.Int 0))] }; - Dcl.Ast.MemberOf { target = "le_hundred"; - binding = [("left", Dcl.Ast.Var "score"); ("right", Dcl.Ast.Const (Drl.Ast.Int 100))] }; + 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 Dcl.Parser.of_string (Dcl.Parser.to_string src) with + 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 = Dcl.Ast.RegisterConstraint { + let src = Icl.Ast.RegisterConstraint { constraint_name = "not_closed"; relation_name = "open_ticket"; - body = Dcl.Ast.Not { - body = Dcl.Ast.MemberOf { target = "closed_ticket"; - binding = [("ticket_id", Dcl.Ast.Var "ticket_id")] }; + body = Icl.Ast.Not { + body = Icl.Ast.MemberOf { target = "closed_ticket"; + binding = [("ticket_id", Icl.Ast.Var "ticket_id")] }; universe = "open_ticket" } } in - match Dcl.Parser.of_string (Dcl.Parser.to_string src) with + match Icl.Parser.of_string (Icl.Parser.to_string src) with | Error _ -> assert false | Ok parsed -> assert (parsed = src) @@ -2630,14 +2630,14 @@ let%test_unit "dcl: execute RegisterConstraint attaches constraint" = let db = match Manipulation.Memory.create_relation storage db ~name:"order_items" ~schema with | Error _ -> assert false | Ok (db, _) -> db in - let stmt = Dcl.Ast.RegisterConstraint { + let stmt = Icl.Ast.RegisterConstraint { constraint_name = "fk_order"; relation_name = "order_items"; - body = Dcl.Ast.MemberOf { target = "orders"; binding = [("order_id", Dcl.Ast.Var "order_id")] } + body = Icl.Ast.MemberOf { target = "orders"; binding = [("order_id", Icl.Ast.Var "order_id")] } } in - match Dcl.Executor.Memory.execute storage db stmt with + match Icl.Executor.Memory.execute storage db stmt with | Error _ -> assert false - | Ok db -> + | Ok (db, _) -> let rel = match Management.Database.get_relation db "order_items" with | None -> assert false | Some r -> r in @@ -2662,13 +2662,13 @@ let%test_unit "dcl: FK constraint enforced on insert" = | Error _ -> assert false | Ok (db, _) -> db in (* Register FK: order_id in order_items must match id in orders *) - let db = match Dcl.Executor.Memory.execute storage db - (Dcl.Ast.RegisterConstraint { + let db = match Icl.Executor.Memory.execute storage db + (Icl.Ast.RegisterConstraint { constraint_name = "fk_order"; relation_name = "order_items"; - body = Dcl.Ast.MemberOf { target = "orders"; binding = [("id", Dcl.Ast.Var "order_id")] } + body = Icl.Ast.MemberOf { target = "orders"; binding = [("id", Icl.Ast.Var "order_id")] } }) with - | Error _ -> assert false | Ok db -> db + | Error _ -> assert false | Ok (db, _) -> db in (* Valid insert: order_id=1 exists in orders *) let db = match Dml.Executor.Memory.execute storage db @@ -2684,3 +2684,249 @@ let%test_unit "dcl: FK constraint enforced on insert" = (Dml.Ast.InsertTuple { relation = "order_items"; attributes = [("order_id", Drl.Ast.Int 99)] }) with | Error (Dml.Executor.Memory.ManipulationError (Manipulation.ConstraintViolation _)) -> () | _ -> assert false) + +(* ============================================================================ + Branch Tests + ============================================================================ *) + +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%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) + +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")) + +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) + +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")) + +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) + +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)) + +(* ============================================================================ + Diff Tests + ============================================================================ *) + +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%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%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%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) + +(* ============================================================================ + Merge Tests + ============================================================================ *) + +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%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%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)) -- cgit v1.2.3