aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMarcos Magueta <maguetamarcos@gmail.com>2026-03-23 23:28:05 -0300
committerGitHub <noreply@github.com>2026-03-23 23:28:05 -0300
commita98fad877fa9ddacb32898b01e23d588f8df04aa (patch)
tree3399847f0ce72d99f8eca00c6ee4d1a71ff70b47
parent59dd901fbe76fc1dfc2d0fd3b725c47735f4bb1c (diff)
downloadSakura-a98fad877fa9ddacb32898b01e23d588f8df04aa.tar.gz
Sakura-a98fad877fa9ddacb32898b01e23d588f8df04aa.zip
Constraint walker and polarity analysis
- Polarity analysis walker on Constraint.t AST - Cascade constraint re-checking on DELETE and INSERT - Focused filtering to narrow re-checks to affected tuples only - Universal variable substitution for targeted constraint re-evaluation - Constant discovery for early bail-out (trigger_constants) - Deferred constraint timing with commit boundary - attach_constraint and commit API in Manipulation - extend_tuple namespacing fix (variable.attr convention) - History capping at 128 entries in Database.update_state - Benchmark binary (bin/bench.ml) - Design doc (docs/incremental_constraint_checking.org)
-rw-r--r--bin/bench.ml202
-rw-r--r--bin/dune6
-rw-r--r--bin/server.ml4
-rw-r--r--docs/incremental_constraint_checking.org261
-rw-r--r--lib/constraint.ml191
-rw-r--r--lib/management/database.ml23
-rw-r--r--lib/manipulation.ml294
-rw-r--r--test/test_relational_engine.ml837
8 files changed, 1664 insertions, 154 deletions
diff --git a/bin/bench.ml b/bin/bench.ml
new file mode 100644
index 0000000..8f496f2
--- /dev/null
+++ b/bin/bench.ml
@@ -0,0 +1,202 @@
+open Relational_engine
+
+(* helpers *)
+
+let time label f =
+ let t0 = Unix.gettimeofday () in
+ f ();
+ let elapsed = Unix.gettimeofday () -. t0 in
+ Printf.printf " %-60s %.4f s\n%!" label elapsed
+
+let mk_int (n : int) : Conventions.AbstractValue.t = Obj.magic n
+
+let make_tuple relation pairs =
+ let attributes =
+ List.fold_left
+ (fun acc (k, v) ->
+ Tuple.AttributeMap.add k { Attribute.value = mk_int v } acc)
+ Tuple.AttributeMap.empty
+ pairs
+ in
+ { Tuple.relation; attributes }
+
+let unwrap label = function
+ | Ok v -> v
+ | Error _ -> failwith label
+
+let get_rel db name =
+ match Manipulation.Memory.get_relation db ~name with
+ | Some r -> r
+ | None -> failwith ("relation not found: " ^ name)
+
+(* database setup *)
+
+(*
+ Schema:
+ Department { dept_id }
+ Employee { emp_id, dept_id }
+
+ Constraint on Employee:
+ Exists d in Department, MemberOf Department (dept_id = Var "dept_id")
+
+ This is a classic FK: every employee must reference an existing department.
+ On the sublanguages branch, deleting a referenced Department triggers a
+ cascade re-check of affected Employee tuples and rejects the delete.
+ On master (no cascade), the delete succeeds unconditionally.
+*)
+let setup storage ~n_depts ~employees_per_dept =
+ let db =
+ unwrap "create_database"
+ (Manipulation.Memory.create_database storage ~name:"bench")
+ in
+ let db =
+ fst (unwrap "create Department"
+ (Manipulation.Memory.create_relation storage db ~name:"Department"
+ ~schema:(Schema.empty |> Schema.add "dept_id" "natural")))
+ in
+ let db =
+ fst (unwrap "create Employee"
+ (Manipulation.Memory.create_relation storage db ~name:"Employee"
+ ~schema:(Schema.empty
+ |> Schema.add "emp_id" "natural"
+ |> Schema.add "dept_id" "natural")))
+ in
+ let fk_body =
+ Constraint.Exists {
+ variable = "d";
+ quantifier = "Department";
+ body = Constraint.MemberOf {
+ target = "Department";
+ binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id");
+ };
+ }
+ in
+ let db =
+ unwrap "register_constraint"
+ (Manipulation.Memory.register_constraint storage db
+ ~constraint_name:"fk_dept"
+ ~relation_name:"Employee"
+ ~body:fk_body)
+ in
+ let dept_tuples =
+ List.init n_depts (fun i ->
+ make_tuple "Department" [("dept_id", i + 1)])
+ in
+ let db =
+ let (db, _, _) = unwrap "insert departments"
+ (Manipulation.Memory.create_tuples storage db
+ (get_rel db "Department") dept_tuples)
+ in db
+ in
+ let emp_tuples =
+ List.init (n_depts * employees_per_dept) (fun i ->
+ make_tuple "Employee" [
+ ("emp_id", i + 1);
+ ("dept_id", (i mod n_depts) + 1);
+ ])
+ in
+ let db =
+ let (db, _, _) = unwrap "insert employees"
+ (Manipulation.Memory.create_tuples storage db
+ (get_rel db "Employee") emp_tuples)
+ in db
+ in
+ db
+
+(* benchmark cases *)
+
+(*
+ Attempt to delete each department that has employees referencing it.
+
+ sublanguages: retract_tuple runs the cascade check — uses polarity analysis
+ to identify Employee as the constrained relation, then focused_filter to
+ narrow the scan to only employees with dept_id = deleted dept_id. Finds a
+ match → returns ConstraintViolation. Delete is rejected.
+
+ master: no cascade logic; retract_tuple succeeds unconditionally and db
+ becomes inconsistent.
+
+ db is not threaded through since on sublanguages every delete is rejected
+ (db state is unchanged after each Error), and on master we deliberately
+ want to measure per-delete cost against a consistent employee set.
+*)
+let bench_retract_referenced storage db ~n_depts =
+ let rel = get_rel db "Department" in
+ for i = 1 to n_depts do
+ let hash = Hashing.hash_tuple (make_tuple "Department" [("dept_id", i)]) in
+ ignore (Manipulation.Memory.retract_tuple storage db rel ~tuple_hash:hash)
+ done
+
+(*
+ Delete departments that have NO referencing employees. Neither branch
+ needs to scan Employee tuples (focused_filter finds no matches), so this
+ measures raw retract_tuple cost: Merkle tree update + storage write.
+
+ We thread db through the loop so each delete builds on the previous state
+ and only one live tree version accumulates in memory at a time.
+
+ Orphan dept ids start at offset to avoid colliding with the employee-owned
+ depts (1..n_depts).
+*)
+let bench_retract_unreferenced storage db ~n_depts ~offset =
+ let orphan_tuples =
+ List.init n_depts (fun i ->
+ make_tuple "Department" [("dept_id", offset + i + 1)])
+ in
+ let db =
+ let (db, _, _) = unwrap "insert orphan depts"
+ (Manipulation.Memory.create_tuples storage db
+ (get_rel db "Department") orphan_tuples)
+ in db
+ in
+ let _db =
+ List.fold_left (fun db i ->
+ let rel = get_rel db "Department" in
+ let hash = Hashing.hash_tuple (make_tuple "Department" [("dept_id", offset + i)]) in
+ match Manipulation.Memory.retract_tuple storage db rel ~tuple_hash:hash with
+ | Ok (db, _) -> db
+ | Error _ -> db)
+ db
+ (List.init n_depts (fun i -> i + 1))
+ in
+ ()
+
+(* entry point *)
+
+let () =
+ let n_depts = 100 in
+ let employees_per_dept = 200 in
+ let total_employees = n_depts * employees_per_dept in
+
+ Printf.printf "\nSakura constraint benchmark\n";
+ Printf.printf " Departments : %d\n" n_depts;
+ Printf.printf " Employees/dept : %d (%d total)\n\n"
+ employees_per_dept total_employees;
+
+ let make_storage () =
+ match Management.Physical.Memory.create () with
+ | Ok s -> s
+ | Error _ -> failwith "create storage"
+ in
+
+ (* Warmup build — not measured *)
+ let storage = make_storage () in
+ ignore (setup storage ~n_depts ~employees_per_dept);
+
+ (* Fresh storage for measured runs *)
+ let storage = make_storage () in
+ let db = setup storage ~n_depts ~employees_per_dept in
+
+ Printf.printf "Scenarios:\n";
+
+ time (Printf.sprintf
+ "retract %d referenced depts (cascade check, violations expected)"
+ n_depts)
+ (fun () -> bench_retract_referenced storage db ~n_depts);
+
+ time (Printf.sprintf
+ "retract %d unreferenced depts (no matching employees)"
+ n_depts)
+ (fun () -> bench_retract_unreferenced storage db ~n_depts ~offset:1_000_000);
+
+ Printf.printf "\n"
diff --git a/bin/dune b/bin/dune
index 5a6c7d4..27cf07a 100644
--- a/bin/dune
+++ b/bin/dune
@@ -11,3 +11,9 @@
(modules server)
(libraries relational_engine unix)
(modes byte exe))
+
+(executable
+ (name bench)
+ (modules bench)
+ (libraries relational_engine unix)
+ (modes exe))
diff --git a/bin/server.ml b/bin/server.ml
index 80f392b..5a59e2e 100644
--- a/bin/server.ml
+++ b/bin/server.ml
@@ -154,11 +154,11 @@ let print_with_time str =
let tm = Unix.localtime now in
let orange = "\027[38;5;208m" in
let reset = "\027[0m" in
- let formatted_time =
+ let formatted_time =
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d"
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
- in
+ in
print_endline @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str
(* TODO: single-threaded accept loop — one slow or hung client blocks all
diff --git a/docs/incremental_constraint_checking.org b/docs/incremental_constraint_checking.org
new file mode 100644
index 0000000..28b9cc5
--- /dev/null
+++ b/docs/incremental_constraint_checking.org
@@ -0,0 +1,261 @@
+#+title: Incremental Constraint Re-checking
+#+date: 2026-03-22
+
+* Background
+
+The naive implementation of assertion-style constraints evaluates the full
+constraint expression on every mutation of every relation it references. This
+is correct but expensive. The state of the art (Oracle's implementation, and
+the PostgreSQL community discussion that informed it) reduces this cost along
+two orthogonal axes:
+
+1. *When* to re-check — polarity analysis eliminates re-checks that cannot
+ possibly produce a violation.
+2. *What* to execute — universal variable substitution replaces the full
+ constraint with a focused incremental expression.
+
+Primary references:
+- Hendrik Decker, /Translating Advanced Integrity Checking Technology to SQL Database/
+- J. M. Nicolas, /Logic for Improving Integrity Checking/
+- Ceri & Widom, /Deriving Production Rules for Constraint Maintenance/
+- Lex de Hann & Toon Koppelaars, /Applied Mathematics for Database Professionals/,
+ ch. 11 (Oracle implementation)
+- PostgreSQL hackers thread (2023):
+ =https://www.postgresql.org/message-id/flat/FD62F1DE-4227-4D67-A1A5-C17350B8CAA1%40elusive.cx=
+
+* Current Sakura State
+
+Constraints are only evaluated inside =create_tuple= against the tuple
+being inserted. =retract_tuple= performs no constraint re-check. This
+means:
+
+- A DELETE from a relation referenced positively in a constraint (e.g. a
+ =Department= relation referenced by an Employee FK constraint) leaves
+ existing tuples in the constrained relation unchecked.
+- Constraints degrade silently into insert-time assertions rather than
+ invariants maintained across all mutations.
+
+Relevant code: =lib/manipulation.ml= (=create_tuple=, =retract_tuple=),
+=lib/constraint.ml= (=evaluate=, =evaluate_named=).
+
+The catalog already seeds =sakura:on= (insert/update/delete) and
+=sakura:timing= (immediate/deferred) relations, indicating that support for
+deferred and per-operation constraint scheduling was anticipated but not
+implemented.
+
+* Technique 1 — Polarity Analysis
+
+** Concept
+
+Every relation reference inside a constraint expression has a *polarity*: the
+set of mutation types that could create a new violation.
+
+| Polarity | Meaning |
+|--------------+-----------------------------------------------------------|
+| ⊕ (positive) | A DELETE from this relation could violate the constraint |
+| ⊖ (negative) | An INSERT into this relation could violate the constraint |
+| ⊕⊖ (both) | Either mutation type could violate the constraint |
+
+Polarity is determined by a tree walk toggling sign at each negating node
+(=NOT=, =EXCEPT=, =NOT EXISTS=). References under =OUTER JOIN= carry both
+polarities.
+
+** Mapping to Sakura's =Constraint.t= AST
+
+#+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
+
+| Constructor | Relation reference | Polarity | Re-check trigger |
+|-------------------------+--------------------+----------+---------------------------------------------|
+| =MemberOf { target }= | =target= | ⊕ | DELETE from =target= |
+| =Not { body }= | refs in =body= | flipped | opposite of body |
+| =Not { universe }= | =universe= | ⊕ | (closed-world annotation; no runtime check) |
+| =Exists { quantifier }= | =quantifier= | ⊕ | DELETE from =quantifier= |
+| =Exists { body }= | refs in =body= | as-is | as normal |
+| =Forall { quantifier }= | =quantifier= | ⊖ | INSERT into =quantifier= |
+| =Forall { body }= | refs in =body= | flipped | opposite of body |
+| =And= / =Or= | refs in children | as-is | propagated |
+
+Note: =Forall x in Q, P(x)= ≡ =NOT (EXISTS x in Q, NOT P(x))=, so =Q=
+acquires negative polarity (the outer =NOT= flips the positive polarity of
+=Exists=).
+
+** Worked Example (Sakura FK constraint)
+
+#+begin_src
+-- Constraint on Employee: dept_id must exist in Department
+Exists d in Department,
+ MemberOf Department (dept_id = Var "dept_id")
+#+end_src
+
+Polarity walk:
+- =Exists { quantifier = "Department" }= -> =Department= is ⊕ (positive)
+- =MemberOf { target = "Department" }= (inside body) -> also ⊕
+
+Re-check schedule derived:
+- INSERT into =Employee=: check immediately (current behavior).
+- DELETE from =Department=: re-check all =Employee= tuples whose =dept_id=
+ equals the deleted department's =dept_id= (currently NOT done!!!!).
+- INSERT into =Department=: no re-check needed.
+
+** Implementation Sketch
+
+A function =polarity : Constraint.t -> (relation_name * polarity_set) list=
+walks the AST accumulating per-relation polarity sets. The result is stored
+alongside each named constraint in the catalog (or derived on demand maybe?).
+
+When =retract_tuple= removes a tuple from relation =R=:
+- Look up all constraints (across all relations) that reference =R= with ⊕ polarity.
+- For each such constraint =C= on relation =S=: schedule a re-check of =C=
+ against existing tuples in =S= that could be affected (see Technique 2).
+
+When =create_tuple= inserts a tuple into =R=:
+- Current behavior: check constraints on =R= itself.
+- Additionally: look up all constraints referencing =R= with ⊖ polarity and
+ schedule re-checks of those (this covers =Forall= quantifiers).
+
+* Technique 2 — Universal Variable Substitution
+
+** Concept
+
+Universally quantified variables in a constraint (those bound by =Forall= or
+appearing under a =NOT EXISTS=) can be substituted with the concrete values of
+the triggering tuple. This transforms the re-check from a full table scan into
+a targeted query over the minimal set of affected rows.
+
+The "transition tuple" (the inserted or deleted tuple) supplies the concrete
+values (the NEW and OLD on PostgreSQL).
+
+** Mapping to Sakura
+
+In Sakura's =Forall { variable; quantifier; body }=:
+
+- =variable= is universally quantified over =quantifier=.
+- When a new row is inserted into =quantifier=, that specific row supplies the
+ binding for =variable=.
+- Instead of re-checking all tuples in the constrained relation =S=, substitute
+ =variable= with the transition tuple's values and check only tuples in =S=
+ that share the constrained attributes.
+
+For the Employee/Department FK example above, on DELETE of Department row
+={dept_id = 99}=:
+
+#+begin_src
+-- Full re-check (naive):
+For every employee E: Exists d in Department, dept_id = E.dept_id
+
+-- Incremental re-check (substituted):
+Exists E in Employee where E.dept_id = 99:
+ NOT (Exists d in Department where d.dept_id = E.dept_id)
+-- i.e., find employees orphaned by this specific deletion
+#+end_src
+
+This is analogous to the PostgreSQL example in the background section, where
+universally quantified =r.n= is substituted with the transition table value.
+
+** Relation to the =extend_tuple= Namespacing Fix
+
+The namespacing fix for =extend_tuple= (prefixing quantifier attributes as
+=variable.attr=) is a prerequisite for universal variable substitution to be
+correct: the substituted binding must be distinguishable from base tuple
+attributes. Both fixes must land together.
+
+* Technique 3 — Constant Discovery
+
+Within a constraint expression, constants (=Const v= in =binding_expr=) can be
+used to filter the re-check trigger:
+
+- If =MemberOf { target; binding }= contains =Const v= bound to attribute =a=,
+ then a DELETE from =target= only needs to trigger a re-check if the deleted
+ row has =a = v=.
+
+Sakura's =binding_expr= already distinguishes =Var= from =Const=, so constant
+discovery is a straightforward fold over the binding map.
+
+* Deferred Constraints
+
+The =sakura:timing= catalog relation (seeded with =immediate= /
+=deferred=) anticipates support for deferred constraint checking
+(analogous to SQL's =DEFERRABLE INITIALLY DEFERRED=). Under deferred
+mode:
+
+- Violations discovered during a sequence of mutations are accumulated
+ rather than immediately raised.
+- The full constraint is re-evaluated at commit time (end of the
+ mutation sequence) using the final database state.
+
+In Sakura's functional/immutable model, a mutation sequence is a fold
+over =Database.t= values. Deferred checking would mean accumulating
+pending re-check obligations alongside the database value and
+evaluating them at the end of the fold, rather than at each
+=create_tuple= / =retract_tuple= call.
+
+* Concurrency Considerations
+
+Under =SERIALIZABLE= isolation, incremental re-checking (Technique 2)
+is sound because the focused predicates cover exactly the rows that
+could be newly violated. Under =READ COMMITTED= (weaker isolation),
+additional care is needed; the Oracle paper (Toon Koppelaars)
+describes how to handle this using the universal variable insight.
+Sakura is currently single-threaded (=bin/server.ml= has a TODO on
+this), so concurrency is deferred.
+
+* Coq Proof Opportunities
+
+See =doc/coq_roadmap.org= (Tier 2 — Certified Constraint Evaluator)
+for related proof targets. The following specific lemmas are unlocked
+by this technique:
+
+1. *Polarity soundness*:
+ #+begin_src coq
+ Theorem polarity_sound_positive :
+ forall c r, polarity c r = Positive ->
+ forall db tuple_deleted,
+ eval c db = true ->
+ eval c (db_without r tuple_deleted) = true \/
+ (exists t, affected_by c r tuple_deleted t).
+ #+end_src
+ Meaning: if a relation has positive polarity in a constraint, only
+ deletions from it can create violations, and only for specifically
+ affected tuples.
+
+2. *Universal substitution completeness*:
+ #+begin_src coq
+ Theorem substitution_complete :
+ forall c var q transition_tuple db,
+ universally_quantified c var q ->
+ eval (substitute c var transition_tuple) db = true ->
+ eval c (db_without q transition_tuple) = true.
+ #+end_src
+ Meaning: if the substituted re-check passes for the transition
+ tuple, the full constraint holds in the updated database.
+
+3. *Constant filter soundness*:
+ #+begin_src coq
+ Theorem constant_filter_sound :
+ forall c r a v deleted_tuple,
+ binding_constant c r a v ->
+ deleted_tuple.(a) <> v ->
+ eval c db = eval c (db_without r deleted_tuple).
+ #+end_src
+ Meaning: if the deleted tuple doesn't match the constant, no
+ re-check is needed.
+
+* Implementation Roadmap
+
+| Step | Work item | Depends on | Status |
+|------+-----------------------------------------------------------------+------------+----------|
+| 1 | Implement =polarity= walker on =Constraint.t= | — | Done |
+| 2 | =extend_tuple= namespacing (=variable.attr= convention) | — | Done |
+| 3 | Store polarity metadata in catalog (=sakura:constraint=) | 1 | — |
+| 4 | =retract_tuple= triggers polarity-driven re-checks | 1, 2 | Done |
+| 5 | Universal variable substitution for focused re-checks | 2 | — |
+| 6 | Constant discovery for trigger filtering | 1 | Done |
+| 7 | Deferred constraint scheduling via =sakura:timing= | 4 | — |
+| 8 | Coq proofs for polarity soundness and substitution completeness | 1–5 | — |
diff --git a/lib/constraint.ml b/lib/constraint.ml
index 0ba7d4f..527a7dc 100644
--- a/lib/constraint.ml
+++ b/lib/constraint.ml
@@ -243,25 +243,18 @@ and extend_tuple (tuple : Tuple.materialized)
(variable : attr_name)
(row : (attr_name * Conventions.AbstractValue.t) list)
: Tuple.materialized =
- (* TODO: Provenance for tuples at the relation level.
- Attributes from quantifier rows are namespaced by the variable name
- (e.g. "d.dept_id") to avoid silent overwriting of same-named attributes
- from the base tuple or other quantifiers. Without namespacing, the
- following FK constraint silently passes for an invalid insertion:
- - Employee { emp_id=1, dept_id=99 } is being inserted.
- - Constraint: Exists d in Department, MemberOf Department (dept_id = Var "dept_id").
- - Department contains only { dept_id=1, dept_name="Engineering" }.
- - extend_tuple overwrites dept_id=99 with dept_id=1 from the Department row.
- - Var "dept_id" resolves to 1, check_membership succeeds trivially.
- - The insertion is accepted even though dept_id=99 does not exist.
- Namespacing is a syntactic encoding of provenance: the variable prefix
- records which quantifier scope each value came from. A more principled
- solution would attach provenance metadata directly to each attribute in
- the relation, making the origin of every value explicit and queryable
- without relying on name conventions. This would also eliminate the
- ambiguity that arises when two quantifiers range over relations sharing
- attribute names — currently resolved by namespacing, but ideally enforced
- structurally by the type system or relation schema. *)
+ (* Quantifier attributes are namespaced by the variable name (for example "d.dept_id")
+ so they cannot silently overwrite same-named attributes from the base tuple
+ or from other quantifiers. Without such namespacing, a constraint like
+ Exists d in Department, MemberOf Department (dept_id = Var "dept_id")
+ would potentially overwrite the base tuple's dept_id with the Department row's dept_id,
+ causing Var "dept_id" to resolve to the wrong value and accept invalid inserts.
+ Constraints reference quantifier attributes as Var "variable.attr"
+ (for example Var "d.dept_id") and base tuple attributes as Var "attr" (like Var "dept_id").
+ This convention is the prerequisite for universal variable substitution
+ (see docs/incremental_constraint_checking.org, specifically Technique 2).
+ A better long-term solution would attach provenance metadata directly
+ to each attribute rather than relying on name conventions, but we don't have that yet. *)
let extra_attrs =
List.fold_left
(fun acc (k, v) ->
@@ -287,6 +280,166 @@ let evaluate_named (ctx : eval_context) (tuple : Tuple.materialized)
| [] -> Ok true
| fs -> Error (ConstraintFailures fs)
+(** Polarity analysis: determines whether each relation name appears in
+ a positive (must-exist) or negative (must-not-exist) position within
+ a constraint tree. Used for cascade checking: when a tuple is deleted,
+ only relations with Positive or Both polarity need re-validation. *)
+
+type polarity = Positive | Negative | Both
+
+let merge_polarity a b =
+ match a, b with
+ | Positive, Positive -> Positive
+ | Negative, Negative -> Negative
+ | _ -> Both
+
+let flip_polarity = function
+ | Positive -> Negative
+ | Negative -> Positive
+ | Both -> Both
+
+let merge_polarity_maps m1 m2 =
+ List.fold_left (fun acc (name, pol) ->
+ match List.assoc_opt name acc with
+ | None -> (name, pol) :: acc
+ | Some prev ->
+ (name, merge_polarity prev pol)
+ :: List.filter (fun (n, _) -> n <> name) acc)
+ m1 m2
+
+let rec polarity_of ?(neg = false) (c : t) : (relation_name * polarity) list =
+ let pos p = if neg then flip_polarity p else p in
+ match c with
+ | MemberOf { target; _ } ->
+ [(target, pos Positive)]
+ | Not { body; _ } ->
+ polarity_of ~neg:(not neg) body
+ | And cs | Or cs ->
+ List.fold_left (fun acc c ->
+ merge_polarity_maps acc (polarity_of ~neg c)) [] cs
+ | Exists { quantifier; body; _ } ->
+ merge_polarity_maps
+ [(quantifier, pos Positive)]
+ (polarity_of ~neg body)
+ | Forall { quantifier; body; _ } ->
+ merge_polarity_maps
+ [(quantifier, pos Negative)]
+ (polarity_of ~neg body)
+
+(** Constraint timing: immediate (checked on every mutation) or deferred
+ (checked at transaction commit). *)
+type timing = Immediate | Deferred
+
+(** Given a constraint, a deleted relation name [dep_rel], and the deleted
+ tuple's attributes, return a filter: [(attr_name, value)] pairs that
+ narrow which constrained-relation tuples could be affected.
+
+ For a Var binding like [dept_id = Var "dept_id"] targeting [dep_rel],
+ the deleted tuple's [dept_id] value becomes the filter: only constrained
+ tuples with that exact [dept_id] need re-checking.
+
+ Returns [] if no narrowing is possible (Const bindings, unrelated rel). *)
+let rec focused_filter (c : t) (dep_rel : relation_name)
+ (deleted : (attr_name * Conventions.AbstractValue.t) list)
+ : (attr_name * Conventions.AbstractValue.t) list =
+ match c with
+ | MemberOf { target; binding } when target = dep_rel ->
+ BindingMap.fold (fun _target_attr expr acc ->
+ match expr with
+ | Var src_attr ->
+ (match List.assoc_opt src_attr deleted with
+ | Some v -> (src_attr, v) :: acc
+ | None -> acc)
+ | Const _ -> acc)
+ binding []
+ | MemberOf _ -> []
+ | Not { body; _ } -> focused_filter body dep_rel deleted
+ | And cs | Or cs ->
+ List.concat_map (fun c -> focused_filter c dep_rel deleted) cs
+ | Exists { body; _ } | Forall { body; _ } ->
+ focused_filter body dep_rel deleted
+
+(** Extract Const binding values from a constraint for a given [dep_rel].
+
+ These are fixed-value preconditions: if the deleted tuple doesn't have
+ these exact values, the constraint cannot be violated by the deletion.
+ The cascade checker uses this to bail out early. *)
+let rec trigger_constants (c : t) (dep_rel : relation_name)
+ : (attr_name * Conventions.AbstractValue.t) list =
+ match c with
+ | MemberOf { target; binding } when target = dep_rel ->
+ BindingMap.fold (fun target_attr expr acc ->
+ match expr with
+ | Const v -> (target_attr, v) :: acc
+ | Var _ -> acc)
+ binding []
+ | MemberOf _ -> []
+ | Not { body; _ } -> trigger_constants body dep_rel
+ | And cs | Or cs ->
+ List.concat_map (fun c -> trigger_constants c dep_rel) cs
+ | Exists { body; _ } | Forall { body; _ } ->
+ trigger_constants body dep_rel
+
+(** Substitute transition tuple values into a constraint for universal variable
+ substitution. When [dep_rel] is being mutated (deleted from or inserted
+ into), any [Exists] or [Forall] that quantifies over [dep_rel] has its body
+ rewritten: occurrences of [Var "variable.attr"] are replaced by
+ [Const value] using the transition tuple's attribute values.
+
+ The convention that quantifier attributes are namespaced as [variable.attr]
+ (established by [extend_tuple]) means base tuple [Var] references like
+ [Var "dept_id"] are never substituted, only [Var "d.dept_id"] would match
+ a quantifier variable [d] over a deleted [Department] row.
+
+ This transforms the recheck from a full relation evaluation into a targeted
+ expression that tests only the rows affected by the transition tuple.
+ See Technique 2 in docs/incremental_constraint_checking.org. *)
+let substitute_transition
+ (c : t)
+ (dep_rel : relation_name)
+ (transition : (attr_name * Conventions.AbstractValue.t) list)
+ : t =
+ let apply_subs subs binding =
+ BindingMap.map (function
+ | Var v -> (match List.assoc_opt v subs with
+ | Some value -> Const value
+ | None -> Var v)
+ | Const _ as expr -> expr)
+ binding
+ in
+ let rec sub_body subs = function
+ | MemberOf { target; binding } ->
+ MemberOf { target; binding = apply_subs subs binding }
+ | Not { body; universe } -> Not { body = sub_body subs body; universe }
+ | And cs -> And (List.map (sub_body subs) cs)
+ | Or cs -> Or (List.map (sub_body subs) cs)
+ | Exists { variable; quantifier; body } ->
+ Exists { variable; quantifier; body = sub_body subs body }
+ | Forall { variable; quantifier; body } ->
+ Forall { variable; quantifier; body = sub_body subs body }
+ in
+ let rec go = function
+ | MemberOf _ as leaf -> leaf
+ | Not { body; universe } -> Not { body = go body; universe }
+ | And cs -> And (List.map go cs)
+ | Or cs -> Or (List.map go cs)
+ | Exists { variable; quantifier; body } ->
+ let body' =
+ if quantifier = dep_rel then
+ sub_body (List.map (fun (a, v) -> (variable ^ "." ^ a, v)) transition) body
+ else go body
+ in
+ Exists { variable; quantifier; body = body' }
+ | Forall { variable; quantifier; body } ->
+ let body' =
+ if quantifier = dep_rel then
+ sub_body (List.map (fun (a, v) -> (variable ^ "." ^ a, v)) transition) body
+ else go body
+ in
+ Forall { variable; quantifier; body = body' }
+ in
+ go c
+
let make_comparison_binding ~left ~right =
BindingMap.empty
|> BindingMap.add "left" left
diff --git a/lib/management/database.ml b/lib/management/database.ml
index 2dc0ae6..c4c6dc3 100644
--- a/lib/management/database.ml
+++ b/lib/management/database.ml
@@ -8,6 +8,12 @@
module RelationMap = Map.Make(String)
+type deferred_entry = {
+ relation_name : string;
+ constraint_name : string;
+ body : Constraint.t;
+}
+
type t = {
hash : Conventions.Hash.t;
name : Conventions.Name.t;
@@ -16,6 +22,7 @@ type t = {
domains : Domain.t RelationMap.t;
history : Conventions.Hash.t list;
timestamp : float;
+ deferred : deferred_entry list;
}
let empty ~name = {
@@ -26,6 +33,7 @@ let empty ~name = {
domains = RelationMap.empty;
history = [];
timestamp = Unix.gettimeofday ();
+ deferred = [];
}
let compute_hash db =
@@ -33,15 +41,26 @@ let compute_hash db =
| Some root -> root
| None -> Conventions.Hash.hash_text db.name
+let max_history = 128
+
+let rec take_at_most n = function
+ | [] -> []
+ | _ when n = 0 -> []
+ | x :: xs -> x :: take_at_most (n - 1) xs
+
let update_state db ~relations ~tree =
let new_hash =
match Merkle.root_hash tree with
| Some root -> root
| None -> Conventions.Hash.hash_text db.name
in
- let history = if db.hash = "" then db.history else db.hash :: db.history in
+ let history =
+ if db.hash = "" then db.history
+ else take_at_most max_history (db.hash :: db.history)
+ in
{ hash = new_hash; name = db.name; tree; relations;
- domains = db.domains; history; timestamp = Unix.gettimeofday () }
+ domains = db.domains; history; timestamp = Unix.gettimeofday ();
+ deferred = db.deferred }
let get_relation db name = RelationMap.find_opt name db.relations
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
index be77c02..58e6cbb 100644
--- a/lib/manipulation.ml
+++ b/lib/manipulation.ml
@@ -261,6 +261,7 @@ module Make (Storage : Management.Physical.S) = struct
domains = Management.Database.RelationMap.empty;
history = stored.history;
timestamp = stored.timestamp;
+ deferred = [];
})
(* Relation Operations - forward declarations needed by catalog helpers
@@ -314,6 +315,123 @@ module Make (Storage : Management.Physical.S) = struct
in
store_all [] attrs
+ (** Load a tuple from storage by its hash *)
+ let load_tuple
+ (storage : storage)
+ (tuple_hash : Conventions.Hash.t)
+ : (Tuple.materialized option, error) Result.t =
+ match Storage.load_raw storage tuple_hash with
+ | Error _ -> Error (StorageError "Failed to load tuple")
+ | Ok None -> Ok None
+ | Ok (Some tuple_bytes) ->
+ let stored = Storable.Tuple.of_bytes tuple_bytes in
+ let rec load_attrs acc = function
+ | [] -> Ok (List.rev acc)
+ | (name, attr_hash) :: rest ->
+ match Storage.load_raw storage attr_hash with
+ | Error _ -> Error (StorageError ("Failed to load attribute: " ^ name))
+ | Ok None -> Error (StorageError ("Attribute not found: " ^ name))
+ | Ok (Some value_bytes) ->
+ let value : Conventions.AbstractValue.t = Marshal.from_bytes value_bytes 0 in
+ let attr : Attribute.materialized = { value } in
+ load_attrs ((name, attr) :: acc) rest
+ in
+ match load_attrs [] stored.attributes with
+ | Error e -> Error e
+ | Ok attrs ->
+ let attributes = List.fold_left
+ (fun m (k, v) -> Tuple.AttributeMap.add k v m)
+ Tuple.AttributeMap.empty attrs
+ in
+ Ok (Some { Tuple.relation = stored.relation; attributes })
+
+ (** Load multiple tuples from storage *)
+ let load_tuples
+ (storage : storage)
+ (hashes : Conventions.Hash.t list)
+ : (Tuple.materialized list, error) Result.t =
+ let rec load_all acc = function
+ | [] -> Ok (List.rev acc)
+ | hash :: rest ->
+ match load_tuple storage hash with
+ | Error e -> Error e
+ | Ok None -> Error (TupleNotFound hash)
+ | Ok (Some tuple) -> load_all (tuple :: acc) rest
+ in
+ load_all [] hashes
+
+ (** Scan every relation in [db] for constraints that reference [dep_rel] with
+ a polarity matched by [polarity_triggers], then re-evaluate those
+ constraints against the affected tuples in each constrained relation.
+
+ [transition] is the inserted or deleted tuple's attributes.
+ [polarity_triggers] returns true for the polarities that the current
+ mutation type can violate:
+ - DELETE: Positive | Both
+ - INSERT: Negative | Both
+
+ Returns [Ok ()] when all cascade checks pass. *)
+ let check_cascade_constraints
+ (storage : storage)
+ (db : Management.Database.t)
+ ~(dep_rel : string)
+ ~(transition : (string * Conventions.AbstractValue.t) list)
+ ~(polarity_triggers : Constraint.polarity -> bool)
+ ~(violation_msg : string -> string -> string)
+ : unit result =
+ let ctx = build_eval_context storage db in
+ Management.Database.RelationMap.fold
+ (fun constrained_name constrained_rel acc ->
+ match acc with Error _ -> acc | Ok () ->
+ let is_deferred cname =
+ List.exists (fun (d : Management.Database.deferred_entry) ->
+ d.constraint_name = cname && d.relation_name = constrained_name)
+ db.deferred
+ in
+ match constrained_rel.Relation.constraints with
+ | None | Some [] -> Ok ()
+ | Some named_constraints ->
+ List.fold_left (fun acc (cname, cbody) ->
+ match acc with Error _ -> acc | Ok () ->
+ if is_deferred cname then Ok ()
+ else
+ let pols = Constraint.polarity_of cbody in
+ match List.assoc_opt dep_rel pols with
+ | None -> Ok ()
+ | Some pol when not (polarity_triggers pol) -> Ok ()
+ | Some _ ->
+ let filter = Constraint.focused_filter cbody dep_rel transition in
+ let hashes = match constrained_rel.tree with
+ | None -> [] | Some t -> Merkle.keys t
+ in
+ let rec check_tuples = function
+ | [] -> Ok ()
+ | h :: rest ->
+ (match load_tuple storage h with
+ | Error _ | Ok None -> check_tuples rest
+ | Ok (Some tup) ->
+ let needs_recheck =
+ filter = [] ||
+ List.for_all (fun (attr, fval) ->
+ match Tuple.AttributeMap.find_opt attr tup.attributes with
+ | Some a -> Stdlib.(=) a.Attribute.value fval
+ | None -> false) filter
+ in
+ if not needs_recheck then check_tuples rest
+ else
+ let cbody' =
+ Constraint.substitute_transition cbody dep_rel transition
+ in
+ match Constraint.evaluate_named ctx tup [(cname, cbody')] with
+ | Ok true -> check_tuples rest
+ | Ok false | Error _ ->
+ Error (ConstraintViolation
+ (violation_msg cname constrained_name)))
+ in
+ check_tuples hashes)
+ (Ok ()) named_constraints)
+ db.relations (Ok ())
+
(** Insert a tuple into a relation, storing it in the backend *)
let create_tuple
(storage : storage)
@@ -398,6 +516,26 @@ module Make (Storage : Management.Physical.S) = struct
(* Update database with the new relation *)
let new_db = Management.Database.update_relation db ~relation:new_relation in
+ (* Cascade constraint check (INSERT) *)
+ let inserted_attrs =
+ Tuple.AttributeMap.bindings tuple.attributes
+ |> List.map (fun (k, attr) -> (k, attr.Attribute.value))
+ in
+ let cascade_ok =
+ check_cascade_constraints storage new_db
+ ~dep_rel:name
+ ~transition:inserted_attrs
+ ~polarity_triggers:(function
+ | Constraint.Negative | Constraint.Both -> true
+ | Constraint.Positive -> false)
+ ~violation_msg:(fun cname crel ->
+ Printf.sprintf
+ "cascade: inserting into %s violates constraint %s on %s"
+ name cname crel)
+ in
+ match cascade_ok with
+ | Error e -> Error e
+ | Ok () ->
(* Persist relation and database state *)
match store_relation storage new_relation with
| Error e -> Error e
@@ -423,53 +561,6 @@ module Make (Storage : Management.Physical.S) = struct
in
insert_all db relation [] tuples
- (** Load a tuple from storage by its hash *)
- let load_tuple
- (storage : storage)
- (tuple_hash : Conventions.Hash.t)
- : (Tuple.materialized option, error) Result.t =
- match Storage.load_raw storage tuple_hash with
- | Error _ -> Error (StorageError "Failed to load tuple")
- | Ok None -> Ok None
- | Ok (Some tuple_bytes) ->
- let stored = Storable.Tuple.of_bytes tuple_bytes in
- (* Load each attribute value *)
- let rec load_attrs acc = function
- | [] -> Ok (List.rev acc)
- | (name, attr_hash) :: rest ->
- match Storage.load_raw storage attr_hash with
- | Error _ -> Error (StorageError ("Failed to load attribute: " ^ name))
- | Ok None -> Error (StorageError ("Attribute not found: " ^ name))
- | Ok (Some value_bytes) ->
- let value : Conventions.AbstractValue.t = Marshal.from_bytes value_bytes 0 in
- let attr : Attribute.materialized = { value } in
- load_attrs ((name, attr) :: acc) rest
- in
- match load_attrs [] stored.attributes with
- | Error e -> Error e
- | Ok attrs ->
- let attributes = List.fold_left
- (fun m (k, v) -> Tuple.AttributeMap.add k v m)
- Tuple.AttributeMap.empty
- attrs
- in
- Ok (Some { Tuple.relation = stored.relation; attributes })
-
- (** Load multiple tuples from storage *)
- let load_tuples
- (storage : storage)
- (hashes : Conventions.Hash.t list)
- : (Tuple.materialized list, error) Result.t =
- let rec load_all acc = function
- | [] -> Ok (List.rev acc)
- | hash :: rest ->
- match load_tuple storage hash with
- | Error e -> Error e
- | Ok None -> Error (TupleNotFound hash)
- | Ok (Some tuple) -> load_all (tuple :: acc) rest
- in
- load_all [] hashes
-
(** Remove a tuple from a relation by its hash *)
let retract_tuple
(storage : storage)
@@ -512,15 +603,37 @@ module Make (Storage : Management.Physical.S) = struct
(* Update database *)
let new_db = Management.Database.update_relation db ~relation:new_relation in
+ (* Cascade constraint check (DELETE) *)
+ let cascade_ok =
+ match load_tuple storage tuple_hash with
+ | Error _ | Ok None -> Ok () (* can't load the deleted tuple, so just skip *)
+ | Ok (Some deleted_tuple) ->
+ let deleted_attrs =
+ Tuple.AttributeMap.bindings deleted_tuple.attributes
+ |> List.map (fun (k, attr) -> (k, attr.Attribute.value))
+ in
+ check_cascade_constraints storage new_db
+ ~dep_rel:name
+ ~transition:deleted_attrs
+ ~polarity_triggers:(function
+ | Constraint.Positive | Constraint.Both -> true
+ | Constraint.Negative -> false)
+ ~violation_msg:(fun cname crel ->
+ Printf.sprintf "cascade: deleting from %s violates constraint %s on %s"
+ name cname crel)
+ in
+ (match cascade_ok with
+ | Error e -> Error e
+ | Ok () ->
(* Persist relation and database state *)
match store_relation storage new_relation with
| Error e -> Error e
| Ok () ->
match store_database storage new_db with
| Error e -> Error e
- | Ok () -> Ok (new_db, new_relation)
+ | Ok () -> Ok (new_db, new_relation))
- (*
+ (*
System Catalog Maintenance
*)
@@ -858,7 +971,7 @@ module Make (Storage : Management.Physical.S) = struct
| None -> constraints
| Some existing -> Constraint.merge existing constraints
in
- (* Don't bake constraint evaluation into membership_criteria —
+ (* Do not bake constraint evaluation into membership_criteria.
create_tuple evaluates constraints with the current db snapshot.
membership_criteria stays for schema/domain validation only. *)
let new_relation =
@@ -942,6 +1055,87 @@ module Make (Storage : Management.Physical.S) = struct
match relation.tree with
| None -> false
| Some tree -> Merkle.member tuple_hash tree
+
+ (** Attach a named constraint with timing metadata.
+ Immediate constraints are added to the relation's constraint list.
+ Deferred constraints are recorded in the database's deferred list
+ and also attached to the relation (for schema visibility). *)
+ let attach_constraint
+ (storage : storage)
+ (db : Management.Database.t)
+ ~(constraint_name : string)
+ ~(relation_name : string)
+ ~(body : Constraint.t)
+ ~(timing : Constraint.timing)
+ : (Management.Database.t, error) Result.t =
+ match update_relation_constraints storage db ~relation_name
+ ~constraints:[(constraint_name, body)] with
+ | Error e -> Error e
+ | Ok (db, _) ->
+ match timing with
+ | Constraint.Immediate -> Ok db
+ | Constraint.Deferred ->
+ let entry : Management.Database.deferred_entry = {
+ relation_name; constraint_name; body;
+ } in
+ Ok { db with deferred = entry :: db.deferred }
+
+ (** Check all deferred constraints against the current database state.
+ Returns [Ok ()] if all pass, or an error on the first violation. *)
+ let check_deferred_constraints
+ (storage : storage)
+ (db : Management.Database.t)
+ : (unit, error) Result.t =
+ List.fold_left (fun acc (entry : Management.Database.deferred_entry) ->
+ match acc with Error _ -> acc | Ok () ->
+ match Management.Database.get_relation db entry.relation_name with
+ | None -> Ok () (* relation gone, nothing to check *)
+ | Some rel ->
+ let ctx = build_eval_context storage db in
+ let hashes = match rel.tree with
+ | None -> [] | Some t -> Merkle.keys t
+ in
+ let rec check = function
+ | [] -> Ok ()
+ | h :: rest ->
+ match load_tuple storage h with
+ | Error _ | Ok None -> check rest
+ | Ok (Some tup) ->
+ match Constraint.evaluate_named ctx tup
+ [(entry.constraint_name, entry.body)] with
+ | Ok true -> check rest
+ | Ok false | Error _ ->
+ Error (ConstraintViolation
+ (Printf.sprintf "deferred constraint %s on %s violated"
+ entry.constraint_name entry.relation_name))
+ in
+ check hashes)
+ (Ok ()) db.deferred
+
+ (** Complete a mutation sequence by evaluating all deferred constraints
+ against the current database state.
+
+ On success, returns the database with the deferred list cleared.
+ Subsequent mutations start a fresh deferral window. On failure,
+ returns the constraint violation error and leaves the database
+ unchanged so the caller can inspect or roll back.
+
+ Typical usage:
+ let db = create_tuple storage db rel t1 in
+ let db = retract_tuple storage db rel t2 in
+ let db = commit storage db in (* deferred checks run here *)
+ ... *)
+ let commit
+ (storage : storage)
+ (db : Management.Database.t)
+ : (Management.Database.t, error) Result.t =
+ match check_deferred_constraints storage db with
+ | Error e -> Error e
+ | Ok () ->
+ let db' = { db with deferred = [] } in
+ match store_database storage db' with
+ | Error e -> Error e
+ | Ok () -> Ok db'
end
(** Default instance using in-memory storage for convenience/testing *)
diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml
index 963337f..081ed39 100644
--- a/test/test_relational_engine.ml
+++ b/test/test_relational_engine.ml
@@ -2,10 +2,6 @@
open Relational_engine
-(* ============================================================================
- Merkle Tree Tests
- ============================================================================ *)
-
let%test_unit "merkle: empty tree" =
let tree = Merkle.empty in
assert (Merkle.is_empty tree);
@@ -70,10 +66,6 @@ let%test_unit "merkle: same elements produce same root hash" =
|> Merkle.insert "a" in
assert (Merkle.root_hash tree1 = Merkle.root_hash tree2)
-(* ============================================================================
- Physical Storage Tests
- ============================================================================ *)
-
let%test_unit "storage: create and close" =
match Management.Physical.Memory.create () with
| Error _ -> assert false
@@ -145,10 +137,6 @@ let%test_unit "storage: transaction commit" =
| Ok exists -> assert exists));
Management.Physical.Memory.close storage
-(* ============================================================================
- Database Tests
- ============================================================================ *)
-
let%test_unit "database: create empty" =
let db = Management.Database.empty ~name:"test_db" in
assert (db.name = "test_db");
@@ -250,10 +238,6 @@ let%test_unit "database: get relation names" =
assert (List.mem "users" names);
assert (List.mem "orders" names)
-(* ============================================================================
- Manipulation Tests (using Memory storage)
- ============================================================================ *)
-
(* Helper to create storage for tests *)
let with_storage f =
match Management.Physical.Memory.create () with
@@ -556,10 +540,6 @@ let%test_unit "manipulation: get_relation from database" =
assert (rel.name = "items");
assert (rel.schema = schema))
-(* ============================================================================
- Schema Persistence Tests
- ============================================================================ *)
-
let%test_unit "schema: persisted and loaded correctly" =
with_storage (fun storage ->
let db = match Manipulation.Memory.create_database storage ~name:"test_db" with
@@ -585,10 +565,6 @@ let%test_unit "schema: persisted and loaded correctly" =
assert (List.mem ("name", "string") loaded_rel.schema);
assert (List.mem ("email", "string") loaded_rel.schema))
-(* ============================================================================
- System Catalog Tests
- ============================================================================ *)
-
let%test_unit "catalog: create_database seeds 6 catalog relations" =
with_storage (fun storage ->
match Manipulation.Memory.create_database storage ~name:"test" with
@@ -714,10 +690,6 @@ let%test_unit "catalog: register_constraint inserts into sakura:constraint" =
in
assert (Manipulation.Memory.tuple_count con_rel = 1))
-(* ============================================================================
- Integration Tests
- ============================================================================ *)
-
let%test_unit "integration: full workflow with storage" =
with_storage (fun storage ->
(* Create database *)
@@ -853,10 +825,6 @@ let%test_unit "integration: hash bubbles up correctly" =
| Some rel_hash ->
assert (Merkle.member rel_hash db.tree))
-(* ============================================================================
- Time-Travel / Branching Tests
- ============================================================================ *)
-
let%test_unit "branching: load database from historical hash" =
with_storage (fun storage ->
let db = match Manipulation.Memory.create_database storage ~name:"test" with
@@ -1044,10 +1012,6 @@ let%test_unit "branching: full reconstruction from hash" =
assert (List.mem "Banana" names);
assert (List.mem "Cherry" names))
-(* ============================================================================
- Algebra Tests
- ============================================================================ *)
-
(* Helper: build a materialized tuple with int attributes *)
let make_int_tuple relation pairs =
let attributes =
@@ -1266,10 +1230,6 @@ let%test_unit "algebra: take limits output" =
| Error _ -> assert false
| Ok rows -> assert (List.length rows = 3))
-(* ============================================================================
- DRL Parser Tests
- ============================================================================ *)
-
let%test_unit "drl: parse Base" =
match Drl.Parser.of_string {|(Base "users")|} with
| Error _ -> assert false
@@ -1295,10 +1255,6 @@ let%test_unit "drl: parse Select" =
| Ok (Drl.Ast.Select (Drl.Ast.Const _, Drl.Ast.Base "users")) -> ()
| Ok _ -> assert false
-(* ============================================================================
- DRL Executor end-to-end Tests
- ============================================================================ *)
-
let%test_unit "drl: execute Base" =
with_storage (fun storage ->
let db = match Manipulation.Memory.create_database storage ~name:"test_db" with
@@ -1352,10 +1308,6 @@ let%test_unit "drl: execute Select+Const" =
in
assert (name_v = "Alice"))
-(* ============================================================================
- Constraint System Tests
- ============================================================================ *)
-
(* ---------- Constraint construction ---------- *)
let%test_unit "constraint: vars_in MemberOf" =
@@ -1883,7 +1835,7 @@ let%test_unit "constraint scenario: mutual exclusion subtypes" =
| Error _ -> assert false
| Ok x -> x
in
- (* Now try to insert same id into manager — should fail *)
+ (* Now try to insert same id into manager, should fail *)
let manager =
match Manipulation.Memory.get_relation db ~name:"manager" with
| None -> assert false
@@ -1970,7 +1922,7 @@ let%test_unit "constraint scenario: foreign key" =
| Error _ -> assert false
| Ok x -> x
in
- (* Insert item referencing valid order — should succeed *)
+ (* Insert item referencing valid order, should succeed *)
let items =
match Manipulation.Memory.get_relation db ~name:"order_items" with
| None -> assert false
@@ -1994,7 +1946,7 @@ let%test_unit "constraint scenario: foreign key" =
| Error _ -> assert false
| Ok x -> x
in
- (* Insert item referencing nonexistent order — should fail *)
+ (* Insert item referencing nonexistent order, should fail *)
let invalid_item : Tuple.materialized =
{
relation = "order_items";
@@ -2074,7 +2026,7 @@ let%test_unit "constraint scenario: self-reference neq" =
| None -> assert false
| Some r -> r
in
- (* Insert (emp_id=1, mgr_id=2) — should succeed *)
+ (* Insert (emp_id=1, mgr_id=2), should succeed *)
let valid : Tuple.materialized =
{
relation = "reports_to";
@@ -2091,7 +2043,7 @@ let%test_unit "constraint scenario: self-reference neq" =
| Error _ -> assert false
| Ok x -> x
in
- (* Insert (emp_id=3, mgr_id=3) — same person, should fail *)
+ (* Insert (emp_id=3, mgr_id=3): same person, should fail *)
let invalid : Tuple.materialized =
{
relation = "reports_to";
@@ -2173,7 +2125,7 @@ let%test_unit "constraint scenario: open vs closed ticket" =
| Error _ -> assert false
| Ok x -> x
in
- (* Try to open same ticket — should fail *)
+ (* Try to open same ticket, should fail *)
let open_ =
match Manipulation.Memory.get_relation db ~name:"open_ticket" with
| None -> assert false
@@ -2256,7 +2208,7 @@ let%test_unit "constraint scenario: weak entity dependency" =
| Error _ -> assert false
| Ok x -> x
in
- (* Insert dependent with valid parent — succeeds *)
+ (* Insert dependent with valid parent, should succeed *)
let dep =
match Manipulation.Memory.get_relation db ~name:"dependent" with
| None -> assert false
@@ -2280,7 +2232,7 @@ let%test_unit "constraint scenario: weak entity dependency" =
| Error _ -> assert false
| Ok x -> x
in
- (* Insert dependent with nonexistent parent — fails *)
+ (* Insert dependent with nonexistent parent, should fail *)
let invalid_dep : Tuple.materialized =
{
relation = "dependent";
@@ -2298,7 +2250,7 @@ let%test_unit "constraint scenario: weak entity dependency" =
| Error (Manipulation.ConstraintViolation _) -> ()
| _ -> assert false)
-(* Scenario 6: Algebra propagation — select preserves constraints *)
+(* Scenario 6: Algebra propagation, select preserves constraints *)
let%test_unit "constraint propagation: select preserves constraints" =
with_storage (fun storage ->
let db =
@@ -2336,7 +2288,7 @@ let%test_unit "constraint propagation: select preserves constraints" =
| Ok result ->
assert (result.Relation.constraints <> None))
-(* Scenario 7: Algebra propagation — project filters constraints *)
+(* Scenario 7: Algebra propagation, project filters constraints *)
let%test_unit "constraint propagation: project filters constraints" =
with_storage (fun storage ->
let db =
@@ -2376,19 +2328,15 @@ let%test_unit "constraint propagation: project filters constraints" =
| None -> assert false
| Some r -> r
in
- (* Project to only "x" — constraint should survive *)
+ (* Project to only "x", constraint should survive *)
(match Algebra.Memory.project storage [ "x" ] rel with
| Error _ -> assert false
| Ok result -> assert (result.Relation.constraints <> None));
- (* Project to only "y" — constraint referencing "x" should be dropped *)
+ (* Project to only "y", constraint referencing "x" should be dropped *)
match Algebra.Memory.project storage [ "y" ] rel with
| Error _ -> assert false
| Ok result -> assert (result.Relation.constraints = None))
-(* ============================================================================
- DML Sublanguage Tests
- ============================================================================ *)
-
(* Parse tests use canonical flat sexp format: (Constructor (field val) ...) *)
let%test_unit "ddl: parse CreateDatabase" =
@@ -2442,7 +2390,7 @@ let%test_unit "ddl: round-trip RegisterDomain" =
| Error _ -> assert false
| Ok parsed -> assert (parsed = src)
-(* Executor tests construct AST directly — no dependency on sexp format *)
+(* Executor tests construct AST directly, no dependency on sexp format *)
let%test_unit "ddl: execute CreateDatabase" =
with_storage (fun storage ->
@@ -2578,10 +2526,6 @@ let%test_unit "dml: insert into nonexistent relation returns error" =
| Error (Dml.Executor.Memory.RelationNotFound "ghost") -> ()
| _ -> assert false)
-(* ============================================================================
- DCL Sublanguage Tests
- ============================================================================ *)
-
let%test_unit "dcl: round-trip RegisterConstraint MemberOf" =
let src = Icl.Ast.RegisterConstraint {
constraint_name = "fk_order";
@@ -2685,10 +2629,6 @@ let%test_unit "dcl: FK constraint enforced on insert" =
| 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" =
@@ -2760,10 +2700,6 @@ let%test_unit "branch: multiple branches are independent" =
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
@@ -2836,10 +2772,6 @@ let%test_unit "diff: modified relation detected with added tuple" =
assert (removed_tuples = [])
| _ -> assert false)
-(* ============================================================================
- Merge Tests
- ============================================================================ *)
-
module MergeMemory = Management.Merge.Make
(Management.Physical.Memory)
(Manipulation.Memory)
@@ -2930,3 +2862,746 @@ let%test_unit "merge: no-op when both sides are identical" =
| Ok (Management.Merge.Clean merged) ->
assert (Management.Database.get_relation_names merged =
Management.Database.get_relation_names base_db))
+
+(* Helper: look up polarity for a relation name in the result list *)
+let find_polarity name pols =
+ List.assoc_opt name pols
+
+let%test_unit "polarity: MemberOf target is Positive" =
+ let c = Constraint.MemberOf {
+ target = "R";
+ binding = Constraint.BindingMap.empty;
+ } in
+ assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Positive)
+
+let%test_unit "polarity: Not MemberOf flips to Negative" =
+ let c = Constraint.Not {
+ body = Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty };
+ universe = "U";
+ } in
+ assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Negative)
+
+let%test_unit "polarity: Exists quantifier is Positive" =
+ let c = Constraint.Exists {
+ variable = "x";
+ quantifier = "Q";
+ body = Constraint.MemberOf { target = "Q"; binding = Constraint.BindingMap.empty };
+ } in
+ assert (find_polarity "Q" (Constraint.polarity_of c) = Some Constraint.Positive)
+
+let%test_unit "polarity: Forall quantifier is Negative" =
+ let c = Constraint.Forall {
+ variable = "x";
+ quantifier = "Q";
+ body = Constraint.MemberOf { target = "T"; binding = Constraint.BindingMap.empty };
+ } in
+ assert (find_polarity "Q" (Constraint.polarity_of c) = Some Constraint.Negative);
+ assert (find_polarity "T" (Constraint.polarity_of c) = Some Constraint.Positive)
+
+let%test_unit "polarity: same relation with both polarities merges to Both" =
+ (* Not(MemberOf R) AND MemberOf R => R appears Negative and Positive => Both *)
+ let c = Constraint.And [
+ Constraint.Not {
+ body = Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty };
+ universe = "U";
+ };
+ Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty };
+ ] in
+ assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Both)
+
+let%test_unit "polarity: Forall body MemberOf keeps Positive" =
+ (* Forall x in Q, MemberOf(T): T still has positive polarity *)
+ let c = Constraint.Forall {
+ variable = "x";
+ quantifier = "Q";
+ body = Constraint.MemberOf { target = "T"; binding = Constraint.BindingMap.empty };
+ } in
+ assert (find_polarity "T" (Constraint.polarity_of c) = Some Constraint.Positive)
+
+let%test_unit "polarity: nested Not double-negation restores Positive" =
+ let c = Constraint.Not {
+ body = Constraint.Not {
+ body = Constraint.MemberOf { target = "R"; binding = Constraint.BindingMap.empty };
+ universe = "U";
+ };
+ universe = "V";
+ } in
+ assert (find_polarity "R" (Constraint.polarity_of c) = Some Constraint.Positive)
+
+let%test_unit "polarity: unrelated relation absent from result" =
+ let c = Constraint.MemberOf {
+ target = "R";
+ binding = Constraint.BindingMap.empty;
+ } in
+ assert (find_polarity "S" (Constraint.polarity_of c) = None)
+
+let abs i = Obj.magic (i : int) (* lift int to AbstractValue for tests *)
+
+let%test_unit "focused_filter: Var binding maps deleted value to constrained attr" =
+ (* Constraint: MemberOf Dept (dept_id = Var "dept_id")
+ Deleted: Dept { dept_id = 99 }
+ Expected filter: [("dept_id", 99)]
+
+ This is the core FK pattern. The Var "dept_id" in the binding says:
+ "the constrained tuple's dept_id must equal whatever the Dept tuple's
+ dept_id is." When we delete Dept{dept_id=99}, focused_filter resolves
+ the Var to the deleted value and returns [("dept_id", 99)].
+
+ The cascade checker uses this to scan only Employee tuples where
+ dept_id=99 rather than re-checking every Employee row. *)
+ let binding =
+ Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id")
+ in
+ let c = Constraint.MemberOf { target = "Dept"; binding } in
+ let deleted = [("dept_id", abs 99)] in
+ let filter = Constraint.focused_filter c "Dept" deleted in
+ assert (List.length filter = 1);
+ assert (fst (List.hd filter) = "dept_id");
+ assert (Stdlib.(=) (snd (List.hd filter)) (abs 99))
+
+let%test_unit "focused_filter: Const binding is ignored (no var link)" =
+ (* Constraint: MemberOf Dept (code = Const "eng")
+ Deleted: Dept { code = "eng" }
+ Expected filter: []
+
+ A Const binding is a fixed literal that restricts which rows the constraint
+ *applies to*: it is not a join condition. There is no Var, so no link
+ exists between the deleted tuple's attributes and the attributes of any
+ constrained relation. focused_filter correctly returns [] here.
+
+ [] does NOT mean "nothing is affected." It means "no tighter filter could
+ be derived": the caller must fall back to re-checking every tuple in the
+ constrained relation. The tempting but wrong reading would be to see
+ that the deleted value "eng" matches Const "eng" and emit [("code","eng")].
+ Doing so would conflate a constraint literal with a join variable. *)
+ let binding =
+ Constraint.BindingMap.singleton "code"
+ (Constraint.Const (Obj.magic ("eng" : string)))
+ in
+ let c = Constraint.MemberOf { target = "Dept"; binding } in
+ let filter = Constraint.focused_filter c "Dept" [("code", Obj.magic ("eng" : string))] in
+ assert (filter = [])
+
+let%test_unit "focused_filter: Exists body MemberOf same relation is followed" =
+ (* Constraint on Employee: Exists d in Dept, MemberOf Dept (dept_id = Var "dept_id")
+ Deleted: Dept { dept_id = 7 }
+ Expected filter on Employee: [("dept_id", 7)]
+
+ Real FK constraints are wrapped in Exists: "there exists a dept d such
+ that this employee's dept_id matches d's dept_id." The dep_rel ("Dept")
+ appears as the Exists quantifier, not directly in a top-level MemberOf.
+
+ focused_filter must recognise this pattern and recurse into the Exists
+ body to find the Var binding. If it stopped at the Exists node and
+ returned [], the cascade checker would lose the narrowing and fall back
+ to scanning every Employee, defeating the optimisation entirely. *)
+ let binding =
+ Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id")
+ in
+ let c = Constraint.Exists {
+ variable = "d";
+ quantifier = "Dept";
+ body = Constraint.MemberOf { target = "Dept"; binding };
+ } in
+ let filter = Constraint.focused_filter c "Dept" [("dept_id", abs 7)] in
+ assert (List.length filter = 1);
+ assert (fst (List.hd filter) = "dept_id")
+
+let%test_unit "focused_filter: unrelated dep_rel yields empty filter" =
+ (* Constraint references relation R. We are deleting from relation S.
+ Expected filter: []
+
+ If the deleted relation does not appear anywhere in the constraint,
+ the deletion cannot possibly affect any constrained tuple since no join
+ variable links them. The cascade checker uses [] as a signal to skip
+ the re-check for this constraint entirely, not to re-check everything. *)
+ let binding =
+ Constraint.BindingMap.singleton "x" (Constraint.Var "x")
+ in
+ let c = Constraint.MemberOf { target = "R"; binding } in
+ let filter = Constraint.focused_filter c "S" [("x", abs 1)] in
+ assert (filter = [])
+
+let%test_unit "trigger_constants: Const value in binding is extracted" =
+ (* Constraint: MemberOf R (status = Const "active")
+ Expected constants: [("status", "active")]
+
+ trigger_constants answers: "for a DELETE from dep_rel to even risk
+ violating this constraint, what attribute values must the deleted tuple
+ have?" A Const binding says the constraint only applies when the dep_rel
+ tuple has that exact value. If the deleted tuple's status ≠ "active",
+ this constraint can never be violated by that deletion, so it is skipped.
+
+ The cascade checker calls trigger_constants before doing any tuple scan
+ and bails out early if the deleted tuple doesn't match. *)
+ let binding =
+ Constraint.BindingMap.singleton "status"
+ (Constraint.Const (Obj.magic ("active" : string)))
+ in
+ let c = Constraint.MemberOf { target = "R"; binding } in
+ let consts = Constraint.trigger_constants c "R" in
+ assert (List.length consts = 1);
+ assert (fst (List.hd consts) = "status")
+
+let%test_unit "trigger_constants: Var binding produces no constant" =
+ (* Constraint: MemberOf R (id = Var "id")
+ Expected constants: []
+
+ A Var binding imposes no fixed-value precondition on the deleted tuple.
+ It is a join variable, not a filter. Any deleted tuple from R could
+ match a constrained tuple via the Var link, so no early-exit is possible.
+ [] means: always proceed to the cascade scan. *)
+ let binding =
+ Constraint.BindingMap.singleton "id" (Constraint.Var "id")
+ in
+ let c = Constraint.MemberOf { target = "R"; binding } in
+ let consts = Constraint.trigger_constants c "R" in
+ assert (consts = [])
+
+let%test_unit "trigger_constants: unrelated dep_rel yields empty" =
+ (* Constraint references relation R. We are deleting from relation S.
+ Expected constants: []
+
+ When dep_rel does not appear in the constraint at all, trigger_constants
+ returns [], meaning no precondition was found so the cascade scan proceeds. However,
+ focused_filter will also return [] for an unrelated dep_rel, causing the
+ cascade checker to skip the re-check for a different reason (no join
+ link). Both [] cases ultimately mean no affected tuples are found. *)
+ let binding =
+ Constraint.BindingMap.singleton "x" (Constraint.Const (abs 1))
+ in
+ let c = Constraint.MemberOf { target = "R"; binding } in
+ let consts = Constraint.trigger_constants c "S" in
+ assert (consts = [])
+
+let%test_unit "substitute_transition: Var \"variable.attr\" is replaced by Const from transition tuple" =
+ (* Constraint: Exists d in Department, MemberOf Target (key = Var "d.dept_id")
+ Transition: Department row { dept_id = 99 }
+ After substitution: Exists d in Department, MemberOf Target (key = Const 99)
+ The namespaced Var "d.dept_id" (quantifier-scoped) is replaced;
+ a base-tuple Var "dept_id" would not be. *)
+ let c =
+ Constraint.Exists {
+ variable = "d"; quantifier = "Department";
+ body = Constraint.MemberOf {
+ target = "Target";
+ binding = Constraint.BindingMap.singleton "key" (Constraint.Var "d.dept_id");
+ };
+ }
+ in
+ let result = Constraint.substitute_transition c "Department" [("dept_id", abs 99)] in
+ (match result with
+ | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } ->
+ (match Constraint.BindingMap.find_opt "key" binding with
+ | Some (Constraint.Const v) -> assert (Stdlib.(=) v (abs 99))
+ | _ -> assert false)
+ | _ -> assert false)
+
+let%test_unit "substitute_transition: base-tuple Var is not substituted" =
+ (* Constraint: Exists d in Department, MemberOf Target (key = Var "dept_id")
+ Var "dept_id" is a base-tuple reference (no "d." prefix), so it must
+ survive substitution unchanged. Only "d.dept_id" would be replaced. *)
+ let c =
+ Constraint.Exists {
+ variable = "d"; quantifier = "Department";
+ body = Constraint.MemberOf {
+ target = "Target";
+ binding = Constraint.BindingMap.singleton "key" (Constraint.Var "dept_id");
+ };
+ }
+ in
+ let result = Constraint.substitute_transition c "Department" [("dept_id", abs 99)] in
+ (match result with
+ | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } ->
+ (match Constraint.BindingMap.find_opt "key" binding with
+ | Some (Constraint.Var "dept_id") -> ()
+ | _ -> assert false)
+ | _ -> assert false)
+
+let%test_unit "substitute_transition: non-matching quantifier relation is unchanged" =
+ (* Constraint: Exists d in Department, MemberOf Target (key = Var "d.dept_id")
+ Transition is for relation "Other", not "Department".
+ The body must survive unmodified. *)
+ let c =
+ Constraint.Exists {
+ variable = "d"; quantifier = "Department";
+ body = Constraint.MemberOf {
+ target = "Target";
+ binding = Constraint.BindingMap.singleton "key" (Constraint.Var "d.dept_id");
+ };
+ }
+ in
+ let result = Constraint.substitute_transition c "Other" [("dept_id", abs 99)] in
+ (match result with
+ | Constraint.Exists { body = Constraint.MemberOf { binding; _ }; _ } ->
+ (match Constraint.BindingMap.find_opt "key" binding with
+ | Some (Constraint.Var "d.dept_id") -> ()
+ | _ -> assert false)
+ | _ -> assert false)
+
+let%test_unit "substitute_transition: substitution applies through And and Not" =
+ (* Constraint:
+ Exists d in Department,
+ And [
+ MemberOf A (x = Var "d.x");
+ Not { MemberOf B (y = Var "d.y"); universe = "B" }
+ ]
+ Transition: { x = 1, y = 2 }
+ After substitution: Var "d.x" -> Const 1, Var "d.y" -> Const 2 *)
+ let c =
+ Constraint.Exists {
+ variable = "d"; quantifier = "Department";
+ body = Constraint.And [
+ Constraint.MemberOf {
+ target = "A";
+ binding = Constraint.BindingMap.singleton "x" (Constraint.Var "d.x");
+ };
+ Constraint.Not {
+ universe = "B";
+ body = Constraint.MemberOf {
+ target = "B";
+ binding = Constraint.BindingMap.singleton "y" (Constraint.Var "d.y");
+ };
+ };
+ ];
+ }
+ in
+ let result = Constraint.substitute_transition c "Department" [("x", abs 1); ("y", abs 2)] in
+ (match result with
+ | Constraint.Exists {
+ body = Constraint.And [
+ Constraint.MemberOf { binding = b1; _ };
+ Constraint.Not { body = Constraint.MemberOf { binding = b2; _ }; _ };
+ ]; _
+ } ->
+ (match Constraint.BindingMap.find_opt "x" b1,
+ Constraint.BindingMap.find_opt "y" b2 with
+ | Some (Constraint.Const v1), Some (Constraint.Const v2) ->
+ assert (Stdlib.(=) v1 (abs 1));
+ assert (Stdlib.(=) v2 (abs 2))
+ | _ -> assert false)
+ | _ -> assert false)
+
+(* Build a minimal db with two relations and an FK constraint:
+ Department { dept_id } <-- Employee { emp_id, dept_id }
+ Constraint on Employee: Exists d in Department, MemberOf Department (dept_id = Var "dept_id") *)
+let setup_fk_db storage =
+ let db = match Manipulation.Memory.create_database storage ~name:"hr" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Department"
+ ~schema:(Schema.empty |> Schema.add "dept_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Employee"
+ ~schema:(Schema.empty
+ |> Schema.add "emp_id" "natural"
+ |> Schema.add "dept_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let fk_body =
+ let binding =
+ Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id")
+ in
+ Constraint.Exists {
+ variable = "d";
+ quantifier = "Department";
+ body = Constraint.MemberOf { target = "Department"; binding };
+ }
+ in
+ let db = match Manipulation.Memory.register_constraint storage db
+ ~constraint_name:"fk_dept"
+ ~relation_name:"Employee"
+ ~body:fk_body with
+ | Error _ -> assert false | Ok db -> db
+ in
+ db
+
+let%test_unit "extend_tuple namespacing: insert Employee with non-existent dept_id is rejected" =
+ (* Regression test for the extend_tuple namespacing bug.
+ Without namespacing, extend_tuple would overwrite the Employee's dept_id=99
+ with the Department row's dept_id=1 during Exists iteration. Var "dept_id"
+ would then resolve to 1, check_membership would succeed, and the insertion
+ would be accepted despite dept_id=99 not existing in Department.
+ With namespacing, Department attributes are stored as d.dept_id=1 and the
+ base Employee attribute dept_id=99 is preserved, so the check correctly fails. *)
+ with_storage (fun storage ->
+ let db = setup_fk_db storage in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 1);
+ ("dept_id", Drl.Ast.Int 99)] }) with
+ | Ok _ -> assert false (* dept_id=99 does not exist in Department *)
+ | Error _ -> ())
+
+let%test_unit "cascade: delete referenced row violates FK and is rejected" =
+ with_storage (fun storage ->
+ let db = setup_fk_db storage in
+ (* Insert Dept 1 and Employee referencing it *)
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 10);
+ ("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with
+ | None -> assert false | Some r -> r
+ in
+ let dept_hash = Hashing.hash_tuple
+ { Tuple.relation = "Department";
+ attributes = Tuple.AttributeMap.singleton "dept_id"
+ { Attribute.value = Obj.magic (1 : int) } }
+ in
+ (* Deleting Dept 1 while Employee references it must fail *)
+ match Manipulation.Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with
+ | Ok _ -> assert false (* should have been rejected *)
+ | Error (Manipulation.ConstraintViolation msg) ->
+ assert (String.length msg > 0)
+ | Error _ -> assert false)
+
+let%test_unit "cascade: delete unreferenced row succeeds" =
+ with_storage (fun storage ->
+ let db = setup_fk_db storage in
+ (* Insert two departments; employee only references dept 1 *)
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 2)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 10);
+ ("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with
+ | None -> assert false | Some r -> r
+ in
+ let dept2_hash = Hashing.hash_tuple
+ { Tuple.relation = "Department";
+ attributes = Tuple.AttributeMap.singleton "dept_id"
+ { Attribute.value = Obj.magic (2 : int) } }
+ in
+ (* Deleting unreferenced Dept 2 must succeed *)
+ match Manipulation.Memory.retract_tuple storage db dept_rel ~tuple_hash:dept2_hash with
+ | Error _ -> assert false
+ | Ok (new_db, _) ->
+ let dept = match Manipulation.Memory.get_relation new_db ~name:"Department" with
+ | None -> assert false | Some r -> r
+ in
+ assert (Manipulation.Memory.tuple_count dept = 1))
+
+let%test_unit "cascade: Negative-polarity relation deletion is not checked" =
+ (* Constraint on Employee: NOT (MemberOf Blacklist (emp_id = Var "emp_id"))
+ Blacklist has Negative polarity (INSERT into Blacklist could violate).
+ DELETE from Blacklist should never trigger a cascade check. *)
+ with_storage (fun storage ->
+ let db = match Manipulation.Memory.create_database storage ~name:"hr" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Blacklist"
+ ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Employee"
+ ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let not_body =
+ let binding =
+ Constraint.BindingMap.singleton "emp_id" (Constraint.Var "emp_id")
+ in
+ Constraint.Not {
+ body = Constraint.MemberOf { target = "Blacklist"; binding };
+ universe = "Employee";
+ }
+ in
+ let db = match Manipulation.Memory.register_constraint storage db
+ ~constraint_name:"not_blacklisted"
+ ~relation_name:"Employee"
+ ~body:not_body with
+ | Error _ -> assert false | Ok db -> db
+ in
+ (* Insert emp_id=5 into Blacklist, then insert emp_id=99 into Employee (unrelated) *)
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Blacklist";
+ attributes = [("emp_id", Drl.Ast.Int 5)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 99)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let bl_rel = match Manipulation.Memory.get_relation db ~name:"Blacklist" with
+ | None -> assert false | Some r -> r
+ in
+ let bl_hash = Hashing.hash_tuple
+ { Tuple.relation = "Blacklist";
+ attributes = Tuple.AttributeMap.singleton "emp_id"
+ { Attribute.value = Obj.magic (5 : int) } }
+ in
+ (* Deleting from Blacklist (negative polarity) must not trigger cascade check *)
+ match Manipulation.Memory.retract_tuple storage db bl_rel ~tuple_hash:bl_hash with
+ | Error _ -> assert false
+ | Ok _ -> ())
+
+let%test_unit "cascade: deferred constraint not checked during retract_tuple" =
+ with_storage (fun storage ->
+ let db = match Manipulation.Memory.create_database storage ~name:"hr" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Department"
+ ~schema:(Schema.empty |> Schema.add "dept_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Employee"
+ ~schema:(Schema.empty
+ |> Schema.add "emp_id" "natural"
+ |> Schema.add "dept_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let fk_body =
+ let binding =
+ Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id")
+ in
+ Constraint.Exists {
+ variable = "d";
+ quantifier = "Department";
+ body = Constraint.MemberOf { target = "Department"; binding };
+ }
+ in
+ (* Register as DEFERRED *)
+ let db = match Manipulation.Memory.attach_constraint storage db
+ ~constraint_name:"fk_dept_deferred"
+ ~relation_name:"Employee"
+ ~body:fk_body
+ ~timing:Constraint.Deferred with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 10);
+ ("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with
+ | None -> assert false | Some r -> r
+ in
+ let dept_hash = Hashing.hash_tuple
+ { Tuple.relation = "Department";
+ attributes = Tuple.AttributeMap.singleton "dept_id"
+ { Attribute.value = Obj.magic (1 : int) } }
+ in
+ (* Deferred: retract_tuple itself should NOT reject the deletion *)
+ match Manipulation.Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with
+ | Error _ -> assert false (* deferred: must pass here *)
+ | Ok (new_db, _) ->
+ (* But check_deferred_constraints must catch the violation *)
+ match Manipulation.Memory.check_deferred_constraints storage new_db with
+ | Ok () -> assert false (* should have caught the violation *)
+ | Error (Manipulation.ConstraintViolation _) -> ()
+ | Error _ -> assert false)
+
+(* INSERT cascade tests.
+
+ Schema:
+ Blacklist { emp_id }
+ Employee { emp_id }
+
+ Constraint on Employee (negative polarity on Blacklist):
+ Not { body = MemberOf Blacklist (emp_id = Var "emp_id"); universe = "Employee" }
+
+ Blacklist has Negative polarity in this constraint, so inserting into Blacklist
+ must trigger a re-check of Employee tuples. *)
+let setup_blacklist_db storage =
+ let db = match Manipulation.Memory.create_database storage ~name:"hr" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Blacklist"
+ ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Employee"
+ ~schema:(Schema.empty |> Schema.add "emp_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let not_body =
+ Constraint.Not {
+ body = Constraint.MemberOf {
+ target = "Blacklist";
+ binding = Constraint.BindingMap.singleton "emp_id" (Constraint.Var "emp_id");
+ };
+ universe = "Employee";
+ }
+ in
+ match Manipulation.Memory.register_constraint storage db
+ ~constraint_name:"not_blacklisted"
+ ~relation_name:"Employee"
+ ~body:not_body with
+ | Error _ -> assert false | Ok db -> db
+
+let%test_unit "cascade INSERT: inserting into Blacklist violates constraint on existing Employee" =
+ (* Employee emp_id=5 already exists. Inserting Blacklist{emp_id=5} must be
+ rejected because the Employee constraint (NOT member of Blacklist) would
+ be violated for the existing emp_id=5 row. *)
+ with_storage (fun storage ->
+ let db = setup_blacklist_db storage in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 5)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Blacklist";
+ attributes = [("emp_id", Drl.Ast.Int 5)] }) with
+ | Ok _ -> assert false (* emp_id=5 exists in Employee, must be rejected *)
+ | Error _ -> ())
+
+let%test_unit "cascade INSERT: inserting into Blacklist with no matching Employee succeeds" =
+ (* Employee emp_id=99 does not exist. Inserting Blacklist{emp_id=5} must
+ succeed because no Employee tuple is affected. *)
+ with_storage (fun storage ->
+ let db = setup_blacklist_db storage in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 99)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Blacklist";
+ attributes = [("emp_id", Drl.Ast.Int 5)] }) with
+ | Error _ -> assert false (* emp_id=5 not in Employee, must succeed *)
+ | Ok _ -> ())
+
+(* commit tests.
+
+ Uses the same Department/Employee FK schema with a DEFERRED constraint.
+ Individual mutations succeed even when they temporarily violate the constraint;
+ commit is the boundary where deferred violations are caught. *)
+let setup_deferred_fk_db storage =
+ let db = match Manipulation.Memory.create_database storage ~name:"hr" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Department"
+ ~schema:(Schema.empty |> Schema.add "dept_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let db = match Manipulation.Memory.create_relation storage db ~name:"Employee"
+ ~schema:(Schema.empty
+ |> Schema.add "emp_id" "natural"
+ |> Schema.add "dept_id" "natural") with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ let fk_body =
+ Constraint.Exists {
+ variable = "d"; quantifier = "Department";
+ body = Constraint.MemberOf {
+ target = "Department";
+ binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id");
+ };
+ }
+ in
+ match Manipulation.Memory.attach_constraint storage db
+ ~constraint_name:"fk_dept"
+ ~relation_name:"Employee"
+ ~body:fk_body
+ ~timing:Constraint.Deferred with
+ | Error _ -> assert false | Ok db -> db
+
+let%test_unit "commit: no deferred constraints, returns Ok with db unchanged" =
+ with_storage (fun storage ->
+ let db = setup_deferred_fk_db storage in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 10);
+ ("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ (* All constraints satisfied, commit must pass *)
+ match Manipulation.Memory.commit storage db with
+ | Error _ -> assert false
+ | Ok _ -> ())
+
+let%test_unit "commit: deferred violation is caught at commit boundary" =
+ with_storage (fun storage ->
+ let db = setup_deferred_fk_db storage in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 10);
+ ("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let dept_rel = match Manipulation.Memory.get_relation db ~name:"Department" with
+ | None -> assert false | Some r -> r
+ in
+ let dept_hash = Hashing.hash_tuple
+ { Tuple.relation = "Department";
+ attributes = Tuple.AttributeMap.singleton "dept_id"
+ { Attribute.value = Obj.magic (1 : int) } }
+ in
+ (* Delete the referenced department. Deferred, so retract succeeds *)
+ let db = match Manipulation.Memory.retract_tuple storage db dept_rel
+ ~tuple_hash:dept_hash with
+ | Error _ -> assert false | Ok (db, _) -> db
+ in
+ (* commit must now catch the orphaned Employee *)
+ match Manipulation.Memory.commit storage db with
+ | Ok _ -> assert false
+ | Error (Manipulation.ConstraintViolation _) -> ()
+ | Error _ -> assert false)
+
+let%test_unit "commit: clears deferred list, second commit passes" =
+ (* After a successful commit the deferred list is empty.
+ A follow-up mutation + commit on the returned db must also work correctly
+ rather than re-running stale entries from the previous window. *)
+ with_storage (fun storage ->
+ let db = setup_deferred_fk_db storage in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Department";
+ attributes = [("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Dml.Executor.Memory.execute storage db
+ (Dml.Ast.InsertTuple { relation = "Employee";
+ attributes = [("emp_id", Drl.Ast.Int 10);
+ ("dept_id", Drl.Ast.Int 1)] }) with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let db = match Manipulation.Memory.commit storage db with
+ | Error _ -> assert false | Ok db -> db
+ in
+ (* Second commit with no new mutations must also pass *)
+ match Manipulation.Memory.commit storage db with
+ | Error _ -> assert false
+ | Ok _ -> ())