Polarity walker, constraint and manipulation refactor with batteries

2 files changed, 89 insertions, 69 deletions

diff --git a/lib/management/database.ml b/lib/management/database.ml
index c4c6dc3..f4d18e8 100644
--- a/lib/management/database.ml
+++ b/lib/management/database.ml
@@ -1,12 +1,12 @@
 (** Database state: a named collection of relations with a Merkle tree over
-    their hashes, a domain registry, and a history chain of prior hashes.
-    All mutations produce a new value; no in-place update. *)
+    their hashes, a domain registry, and a history chain of prior hashes. All
+    mutations produce a new value; no in-place update. *)
 
 (* TODO: history is an unbounded list of hashes; there is no way to
    reconstruct a past state from a hash alone without a separate snapshot
    store. Either cap the history or make it actually useful. *)
 
-module RelationMap = Map.Make(String)
+module RelationMap = Map.Make (String)
 
 type deferred_entry = {
   relation_name : string;
@@ -25,16 +25,17 @@ type t = {
   deferred : deferred_entry list;
 }
 
-let empty ~name = {
-  hash = "";
-  name;
-  tree = Merkle.empty;
-  relations = RelationMap.empty;
-  domains = RelationMap.empty;
-  history = [];
-  timestamp = Unix.gettimeofday ();
-  deferred = [];
-}
+let empty ~name =
+  {
+    hash = "";
+    name;
+    tree = Merkle.empty;
+    relations = RelationMap.empty;
+    domains = RelationMap.empty;
+    history = [];
+    timestamp = Unix.gettimeofday ();
+    deferred = [];
+  }
 
 let compute_hash db =
   match Merkle.root_hash db.tree with
@@ -44,8 +45,8 @@ let compute_hash db =
 let max_history = 128
 
 let rec take_at_most n = function
-  | []      -> []
-  | _  when n = 0 -> []
+  | [] -> []
+  | _ when n = 0 -> []
   | x :: xs -> x :: take_at_most (n - 1) xs
 
 let update_state db ~relations ~tree =
@@ -58,9 +59,16 @@ let update_state db ~relations ~tree =
     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 ();
-    deferred = db.deferred }
+  {
+    hash = new_hash;
+    name = db.name;
+    tree;
+    relations;
+    domains = db.domains;
+    history;
+    timestamp = Unix.gettimeofday ();
+    deferred = db.deferred;
+  }
 
 let get_relation db name = RelationMap.find_opt name db.relations
 
@@ -74,16 +82,18 @@ let get_relation_names db =
 
 let has_relation db name = RelationMap.mem name db.relations
 
+let relation_hash_or_compute (relation : Relation.t) =
+  match relation.hash with
+  | Some h -> h
+  | None ->
+      let tree = Option.value relation.tree ~default:Merkle.empty in
+      Hashing.hash_relation ~name:relation.name ~schema:relation.schema ~tree
+
 (* TODO: computing the hash here for hash:None relations (ephemeral/prelude)
    is a layering violation — callers should assign the hash before calling
    add_relation, not rely on this fallback. *)
 let add_relation db ~(relation : Relation.t) =
-  let relation_hash = match relation.hash with
-    | Some h -> h
-    | None ->
-      let tree = Option.value relation.tree ~default:Merkle.empty in
-      Hashing.hash_relation ~name:relation.name ~schema:relation.schema ~tree
-  in
+  let relation_hash = relation_hash_or_compute relation in
   let relation = { relation with hash = Some relation_hash } in
   let tree = Merkle.insert relation_hash db.tree in
   let relations = RelationMap.add relation.name relation db.relations in
@@ -93,21 +103,21 @@ let remove_relation db ~name =
   match RelationMap.find_opt name db.relations with
   | None -> db
   | Some relation ->
-    let relation_hash = Option.get relation.hash in
-    let tree = Merkle.delete relation_hash db.tree in
-    let relations = RelationMap.remove name db.relations in
-    update_state db ~relations ~tree
+      let relation_hash = relation_hash_or_compute relation in
+      let tree = Merkle.delete relation_hash db.tree in
+      let relations = RelationMap.remove name db.relations in
+      update_state db ~relations ~tree
 
 let update_relation db ~(relation : Relation.t) =
   let name = relation.name in
   match RelationMap.find_opt name db.relations with
   | None -> db
   | Some old_relation ->
-    let old_hash = Option.get old_relation.hash in
-    let new_hash = Option.get relation.hash in
-    let tree = db.tree |> Merkle.delete old_hash |> Merkle.insert new_hash in
-    let relations = RelationMap.add name relation db.relations in
-    update_state db ~relations ~tree
+      let old_hash = relation_hash_or_compute old_relation in
+      let new_hash = relation_hash_or_compute relation in
+      let tree = db.tree |> Merkle.delete old_hash |> Merkle.insert new_hash in
+      let relations = RelationMap.add name relation db.relations in
+      update_state db ~relations ~tree
 
 let add_domain db (domain : Domain.t) =
   { db with domains = RelationMap.add domain.name domain db.domains }
diff --git a/lib/management/diff.ml b/lib/management/diff.ml
index 865c757..8fca0af 100644
--- a/lib/management/diff.ml
+++ b/lib/management/diff.ml
@@ -1,24 +1,24 @@
-(** Structural delta between two Database.t states.
-    Computes what changed from ancestor → target at the relation level. *)
+(** Structural delta between two Database.t states. Computes what changed from
+    ancestor -> target at the relation level. *)
 
 type relation_diff =
-  | RelationAdded   of Relation.t
+  | RelationAdded of Relation.t
   | RelationRemoved of string
   | RelationModified of {
-      name           : string;
-      added_tuples   : Conventions.Hash.t list;
+      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;
+  ancestor : Conventions.Hash.t;
+  left : Conventions.Hash.t;
+  right : Conventions.Hash.t;
   relation_diffs : relation_diff list;
 }
 
-module StringSet = Set.Make(String)
+module StringSet = Set.Make (String)
 
 let relation_keys rel =
   match rel.Relation.tree with
@@ -30,31 +30,41 @@ 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 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 []
+  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 -> (
+          match Database.get_relation target name with
+          | Some rel -> RelationAdded rel :: acc
+          | None -> acc)
+      | true, false -> RelationRemoved name :: acc
+      | true, true -> (
+          match
+            ( Database.get_relation ancestor name,
+              Database.get_relation target name )
+          with
+          | Some anc_rel, Some tgt_rel ->
+              (* Compare hashes — if identical, no diff *)
+              if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc
+              else
+                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
+          | _ -> acc)
+      | false, false -> acc (* impossible *))
+    all_names []