aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/dcl/ast.ml24
-rw-r--r--lib/dcl/executor.ml126
-rw-r--r--lib/dcl/parser.ml8
-rw-r--r--lib/icl/ast.ml23
-rw-r--r--lib/icl/executor.ml50
-rw-r--r--lib/icl/parser.ml9
-rw-r--r--lib/management/branch.ml138
-rw-r--r--lib/management/diff.ml60
-rw-r--r--lib/management/merge.ml235
-rw-r--r--lib/manipulation.ml2
-rw-r--r--lib/prelude/catalog.ml3
11 files changed, 617 insertions, 61 deletions
diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml
index 95e0271..e1dae13 100644
--- a/lib/dcl/ast.ml
+++ b/lib/dcl/ast.ml
@@ -1,23 +1,13 @@
open Sexplib.Std
-type binding_expr =
- | Var of string
- | Const of Drl.Ast.value (** reuse DRL value for literals *)
-[@@deriving sexp]
-
-type constraint_body =
- | MemberOf of { target: string; binding: (string * binding_expr) list }
- | Not of { body: constraint_body; universe: string }
- | And of constraint_body list
- | Or of constraint_body list
- | Exists of { variable: string; quantifier: string; body: constraint_body }
- | Forall of { variable: string; quantifier: string; body: constraint_body }
+type merge_strategy = PreferLeft | PreferRight | RevertToAncestor
[@@deriving sexp]
type statement =
- | RegisterConstraint of {
- constraint_name: string;
- relation_name: string;
- body: constraint_body;
- }
+ | CreateBranch of { name: string; hash: string option [@sexp.option] }
+ | Checkout of string
+ | GetHead
+ | GetBranchTip of string
+ | UpdateBranchTip of { name: string; hash: string }
+ | Merge of { left: string; right: string; strategy: merge_strategy }
[@@deriving sexp]
diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml
index 810781f..bf549ec 100644
--- a/lib/dcl/executor.ml
+++ b/lib/dcl/executor.ml
@@ -1,54 +1,94 @@
-module Make (Storage : Management.Physical.S) = struct
- module Ops = Manipulation.Make(Storage)
+module Make (Storage : Management.Physical.S with type error = string) = struct
+ module Ops = Manipulation.Make(Storage)
+ module Branch = Management.Branch.Make(Storage)
+ module MergeOps = Management.Merge.Make(Storage)(Ops)
type error =
- | ManipulationError of Manipulation.error
- | ConversionError of string
-
- let wrap_manip = Result.map_error (fun e -> ManipulationError e)
-
- (** Convert a DCL binding_expr to a runtime Constraint.binding_expr *)
- let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function
- | Ast.Var name -> Constraint.Var name
- | Ast.Const value -> Constraint.Const (Drl.Ast.value_to_abstract value)
-
- (** Convert a list of (target_attr, binding_expr) pairs to a Constraint.binding (BindingMap) *)
- let convert_binding (pairs : (string * Ast.binding_expr) list) : Constraint.binding =
- List.fold_left
- (fun acc (key, expr) ->
- Constraint.BindingMap.add key (convert_binding_expr expr) acc)
- Constraint.BindingMap.empty
- pairs
-
- (** Convert a DCL constraint_body AST to a runtime Constraint.t *)
- let rec convert_body : Ast.constraint_body -> Constraint.t = function
- | Ast.MemberOf { target; binding } ->
- Constraint.MemberOf { target; binding = convert_binding binding }
- | Ast.Not { body; universe } ->
- Constraint.Not { body = convert_body body; universe }
- | Ast.And bodies ->
- Constraint.And (List.map convert_body bodies)
- | Ast.Or bodies ->
- Constraint.Or (List.map convert_body bodies)
- | Ast.Exists { variable; quantifier; body } ->
- Constraint.Exists { variable; quantifier; body = convert_body body }
- | Ast.Forall { variable; quantifier; body } ->
- Constraint.Forall { variable; quantifier; body = convert_body body }
+ | BranchError of string
+ | MergeError of string
+
+ let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = function
+ | Ast.PreferLeft -> Management.Merge.PreferLeft
+ | Ast.PreferRight -> Management.Merge.PreferRight
+ | Ast.RevertToAncestor -> Management.Merge.RevertToAncestor
+
+ let manip_err = function
+ | Manipulation.RelationNotFound s -> "RelationNotFound: " ^ s
+ | Manipulation.RelationAlreadyExists s -> "RelationAlreadyExists: " ^ s
+ | Manipulation.TupleNotFound h -> "TupleNotFound: " ^ h
+ | Manipulation.DuplicateTuple h -> "DuplicateTuple: " ^ h
+ | Manipulation.ConstraintViolation s -> "ConstraintViolation: " ^ s
+ | Manipulation.StorageError s -> "StorageError: " ^ s
let execute
(storage : Storage.t)
(db : Management.Database.t)
(stmt : Ast.statement)
- : (Management.Database.t, error) result =
+ : (Management.Database.t * string, error) result =
match stmt with
- | Ast.RegisterConstraint { constraint_name; relation_name; body } ->
- (* TODO: Additional constraint operations (drop constraint, list constraints,
- validate existing tuples against new constraint) are not supported via DCL.
- Use the OCaml API for these advanced operations. *)
- let runtime_body = convert_body body in
- Ops.register_constraint storage db
- ~constraint_name ~relation_name ~body:runtime_body
- |> wrap_manip
+
+ | Ast.CreateBranch { name; hash } ->
+ let tip = match hash with
+ | Some h -> h
+ | None -> db.Management.Database.hash
+ in
+ (match Branch.create storage ~name ~tip with
+ | Error e -> Error (BranchError e)
+ | Ok () -> Ok (db, "Branch " ^ name ^ " created"))
+
+ | Ast.Checkout branch_name ->
+ (match Branch.get_tip storage branch_name with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name))
+ | Ok (Some tip) ->
+ (match Branch.checkout storage branch_name with
+ | Error e -> Error (BranchError e)
+ | Ok () ->
+ (match Ops.load_database storage tip with
+ | Error e -> Error (BranchError (manip_err e))
+ | Ok None -> Error (BranchError ("No database at hash: " ^ tip))
+ | Ok (Some loaded_db) ->
+ Ok (loaded_db, "HEAD:" ^ branch_name))))
+
+ | Ast.GetHead ->
+ (match Branch.get_head storage with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Ok (db, "HEAD is unset")
+ | Ok (Some name) -> Ok (db, "HEAD:" ^ name))
+
+ | Ast.GetBranchTip name ->
+ (match Branch.get_tip storage name with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Error (BranchError ("Branch not found: " ^ name))
+ | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash))
+
+ | Ast.UpdateBranchTip { name; hash } ->
+ (match Branch.update_tip storage ~name ~tip:hash with
+ | Error e -> Error (BranchError e)
+ | Ok () -> Ok (db, "Branch " ^ name ^ " updated"))
+
+ | Ast.Merge { left; right; strategy } ->
+ (match Branch.get_tip storage left, Branch.get_tip storage right with
+ | Error e, _ | _, Error e -> Error (BranchError e)
+ | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left))
+ | _, Ok None -> Error (BranchError ("Branch not found: " ^ right))
+ | Ok (Some left_tip), Ok (Some right_tip) ->
+ let strat = convert_strategy strategy in
+ (match MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip with
+ | Error e -> Error (MergeError (manip_err e))
+ | Ok (Management.Merge.Failed conflicts) ->
+ let msgs = List.map (function
+ | Management.Merge.TupleConflict { relation; hash } ->
+ "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
+ | Management.Merge.SchemaConflict r -> "schema conflict in " ^ r
+ | Management.Merge.ConstraintConflict r -> "constraint conflict in " ^ r
+ ) conflicts in
+ Error (MergeError ("Merge failed: " ^ String.concat "; " msgs))
+ | Ok (Management.Merge.Clean merged_db) ->
+ let _ = Branch.update_tip storage ~name:left
+ ~tip:merged_db.Management.Database.hash in
+ Ok (merged_db,
+ "Merged:" ^ right ^ "→" ^ left)))
end
module Memory = Make(Management.Physical.Memory)
diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml
index a7981c0..3caf748 100644
--- a/lib/dcl/parser.ml
+++ b/lib/dcl/parser.ml
@@ -1,7 +1,13 @@
type error = ParseError of string
let of_string s =
- match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
+ (* ppx_sexp_conv encodes no-argument variants as bare atoms, so
+ unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *)
+ let sexp = match Sexplib.Sexp.of_string s with
+ | Sexplib.Sexp.List [atom] -> atom
+ | other -> other
+ in
+ match Ast.statement_of_sexp sexp with
| stmt -> Ok stmt
| exception exn -> Error (ParseError (Printexc.to_string exn))
diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml
new file mode 100644
index 0000000..95e0271
--- /dev/null
+++ b/lib/icl/ast.ml
@@ -0,0 +1,23 @@
+open Sexplib.Std
+
+type binding_expr =
+ | Var of string
+ | Const of Drl.Ast.value (** reuse DRL value for literals *)
+[@@deriving sexp]
+
+type constraint_body =
+ | MemberOf of { target: string; binding: (string * binding_expr) list }
+ | Not of { body: constraint_body; universe: string }
+ | And of constraint_body list
+ | Or of constraint_body list
+ | Exists of { variable: string; quantifier: string; body: constraint_body }
+ | Forall of { variable: string; quantifier: string; body: constraint_body }
+[@@deriving sexp]
+
+type statement =
+ | RegisterConstraint of {
+ constraint_name: string;
+ relation_name: string;
+ body: constraint_body;
+ }
+[@@deriving sexp]
diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml
new file mode 100644
index 0000000..a895135
--- /dev/null
+++ b/lib/icl/executor.ml
@@ -0,0 +1,50 @@
+module Make (Storage : Management.Physical.S) = struct
+ module Ops = Manipulation.Make(Storage)
+
+ type error =
+ | ManipulationError of Manipulation.error
+ | ConversionError of string
+
+ let wrap_manip = Result.map_error (fun e -> ManipulationError e)
+
+ let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function
+ | Ast.Var name -> Constraint.Var name
+ | Ast.Const value -> Constraint.Const (Drl.Ast.value_to_abstract value)
+
+ let convert_binding (pairs : (string * Ast.binding_expr) list) : Constraint.binding =
+ List.fold_left
+ (fun acc (key, expr) ->
+ Constraint.BindingMap.add key (convert_binding_expr expr) acc)
+ Constraint.BindingMap.empty
+ pairs
+
+ let rec convert_body : Ast.constraint_body -> Constraint.t = function
+ | Ast.MemberOf { target; binding } ->
+ Constraint.MemberOf { target; binding = convert_binding binding }
+ | Ast.Not { body; universe } ->
+ Constraint.Not { body = convert_body body; universe }
+ | Ast.And bodies ->
+ Constraint.And (List.map convert_body bodies)
+ | Ast.Or bodies ->
+ Constraint.Or (List.map convert_body bodies)
+ | Ast.Exists { variable; quantifier; body } ->
+ Constraint.Exists { variable; quantifier; body = convert_body body }
+ | Ast.Forall { variable; quantifier; body } ->
+ Constraint.Forall { variable; quantifier; body = convert_body body }
+
+ let execute
+ (storage : Storage.t)
+ (db : Management.Database.t)
+ (stmt : Ast.statement)
+ : (Management.Database.t * string, error) result =
+ match stmt with
+ | Ast.RegisterConstraint { constraint_name; relation_name; body } ->
+ let runtime_body = convert_body body in
+ (match Ops.register_constraint storage db
+ ~constraint_name ~relation_name ~body:runtime_body
+ |> wrap_manip with
+ | Ok new_db -> Ok (new_db, "Constraint registered: " ^ constraint_name)
+ | Error e -> Error e)
+end
+
+module Memory = Make(Management.Physical.Memory)
diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml
new file mode 100644
index 0000000..a7981c0
--- /dev/null
+++ b/lib/icl/parser.ml
@@ -0,0 +1,9 @@
+type error = ParseError of string
+
+let of_string s =
+ match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
+ | stmt -> Ok stmt
+ | exception exn -> Error (ParseError (Printexc.to_string exn))
+
+let to_string stmt =
+ Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/management/branch.ml b/lib/management/branch.ml
new file mode 100644
index 0000000..70dfd85
--- /dev/null
+++ b/lib/management/branch.ml
@@ -0,0 +1,138 @@
+(** Branch registry: named pointers to database tip hashes, plus HEAD tracking.
+ Stored in the Physical backend under reserved key prefixes:
+ - "branch:<name>" → serialized { name; tip }
+ - "branch_names" → serialized string list (index for enumeration)
+ - "head" → branch name as raw bytes *)
+
+type t = {
+ name : string;
+ tip : Conventions.Hash.t;
+}
+
+type head = string
+
+type error = string
+
+let branch_key name = "branch:" ^ name
+let head_key = "head"
+let names_key = "branch_names"
+
+module Make (Storage : Physical.S with type error = string) = struct
+
+ let load_names storage =
+ match Storage.load_raw storage names_key with
+ | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list)
+ | _ -> []
+
+ let store_names storage names =
+ let bytes = Marshal.to_bytes names [] in
+ ignore (Storage.store_raw storage names_key bytes)
+
+ let create storage ~name ~tip =
+ let record = { name; tip } in
+ let bytes = Marshal.to_bytes record [] in
+ (match Storage.store_raw storage (branch_key name) bytes with
+ | Error e -> Error e
+ | Ok () ->
+ let names = load_names storage in
+ if not (List.mem name names) then
+ store_names storage (name :: names);
+ Ok ())
+
+ let checkout storage branch_name =
+ let bytes = Bytes.of_string branch_name in
+ Storage.store_raw storage head_key bytes
+
+ let get_head storage =
+ match Storage.load_raw storage head_key with
+ | Ok (Some bytes) -> Ok (Some (Bytes.to_string bytes))
+ | Ok None -> Ok None
+ | Error e -> Error e
+
+ let get_tip storage name =
+ match Storage.load_raw storage (branch_key name) with
+ | Ok (Some bytes) ->
+ let record : t = Marshal.from_bytes bytes 0 in
+ Ok (Some record.tip)
+ | Ok None -> Ok None
+ | Error e -> Error e
+
+ let update_tip storage ~name ~tip =
+ match Storage.load_raw storage (branch_key name) with
+ | Ok (Some _) ->
+ let record = { name; tip } in
+ let bytes = Marshal.to_bytes record [] in
+ Storage.store_raw storage (branch_key name) bytes
+ | Ok None -> Error ("Branch not found: " ^ name)
+ | Error e -> Error e
+
+ let list storage =
+ let names = load_names storage in
+ let branches = List.filter_map (fun name ->
+ match get_tip storage name with
+ | Ok (Some tip) -> Some (name, tip)
+ | _ -> None
+ ) names in
+ Ok branches
+
+ let branch_relation storage : Relation.t =
+ let schema =
+ Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string"
+ in
+ let mk v = { Attribute.value = Obj.repr v } in
+ let rec generator position =
+ match position with
+ | None -> Generator.Error "random access not supported for sakura:branch"
+ | Some pos ->
+ (match list storage with
+ | Error _ -> Generator.Done
+ | Ok branches ->
+ if pos >= List.length branches then Generator.Done
+ else
+ let (name, tip) = List.nth branches pos in
+ let short = String.sub tip 0 (min 8 (String.length tip)) in
+ let attributes =
+ Tuple.AttributeMap.of_list
+ [ ("name", mk name)
+ ; ("hash", mk short)
+ ]
+ in
+ Generator.Value
+ ( Tuple.make_materialized ~relation:Prelude.Catalog.branch_rel_name ~attributes
+ , generator ))
+ in
+ Relation.make ~hash:None ~name:Prelude.Catalog.branch_rel_name ~schema
+ ~tree:None ~constraints:None
+ ~cardinality:Conventions.Cardinality.ConstrainedFinite
+ ~generator:(Some generator)
+ ~membership_criteria:(fun _ -> true)
+ ~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name)
+ ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name)
+
+ let head_relation storage : Relation.t =
+ let schema = Schema.empty |> Schema.add "branch" "string" in
+ let mk v = { Attribute.value = Obj.repr v } in
+ let generator position =
+ match position with
+ | None -> Generator.Error "random access not supported for sakura:head"
+ | Some 0 ->
+ (match get_head storage with
+ | Ok None | Error _ -> Generator.Done
+ | Ok (Some branch_name) ->
+ let attributes =
+ Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ]
+ in
+ Generator.Value
+ ( Tuple.make_materialized ~relation:Prelude.Catalog.head_rel_name ~attributes
+ , fun _ -> Generator.Done ))
+ | Some _ -> Generator.Done
+ in
+ Relation.make ~hash:None ~name:Prelude.Catalog.head_rel_name ~schema
+ ~tree:None ~constraints:None
+ ~cardinality:Conventions.Cardinality.ConstrainedFinite
+ ~generator:(Some generator)
+ ~membership_criteria:(fun _ -> true)
+ ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name)
+ ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name)
+
+end
diff --git a/lib/management/diff.ml b/lib/management/diff.ml
new file mode 100644
index 0000000..865c757
--- /dev/null
+++ b/lib/management/diff.ml
@@ -0,0 +1,60 @@
+(** Structural delta between two Database.t states.
+ Computes what changed from ancestor → target at the relation level. *)
+
+type relation_diff =
+ | RelationAdded of Relation.t
+ | RelationRemoved of string
+ | RelationModified of {
+ name : string;
+ added_tuples : Conventions.Hash.t list;
+ removed_tuples : Conventions.Hash.t list;
+ schema_changed : bool;
+ }
+
+type t = {
+ ancestor : Conventions.Hash.t;
+ left : Conventions.Hash.t;
+ right : Conventions.Hash.t;
+ relation_diffs : relation_diff list;
+}
+
+module StringSet = Set.Make(String)
+
+let relation_keys rel =
+ match rel.Relation.tree with
+ | None -> StringSet.empty
+ | Some tree -> StringSet.of_list (Merkle.keys tree)
+
+(** Compute relation-level diffs from ancestor → target. *)
+let diff ~ancestor ~(target : Database.t) =
+ let ancestor_names =
+ Database.get_relation_names ancestor |> StringSet.of_list
+ in
+ let target_names =
+ Database.get_relation_names target |> StringSet.of_list
+ in
+ let all_names = StringSet.union ancestor_names target_names in
+ StringSet.fold (fun name acc ->
+ let in_ancestor = StringSet.mem name ancestor_names in
+ let in_target = StringSet.mem name target_names in
+ match in_ancestor, in_target with
+ | false, true ->
+ let rel = Option.get (Database.get_relation target name) in
+ RelationAdded rel :: acc
+ | true, false ->
+ RelationRemoved name :: acc
+ | true, true ->
+ let anc_rel = Option.get (Database.get_relation ancestor name) in
+ let tgt_rel = Option.get (Database.get_relation target name) in
+ (* Compare hashes — if identical, no diff *)
+ if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc
+ else begin
+ let anc_keys = relation_keys anc_rel in
+ let tgt_keys = relation_keys tgt_rel in
+ let added_tuples = StringSet.diff tgt_keys anc_keys |> StringSet.elements in
+ let removed_tuples = StringSet.diff anc_keys tgt_keys |> StringSet.elements in
+ let schema_changed = anc_rel.Relation.schema <> tgt_rel.Relation.schema in
+ RelationModified { name; added_tuples; removed_tuples; schema_changed } :: acc
+ end
+ | false, false -> acc (* impossible *)
+ ) all_names []
diff --git a/lib/management/merge.ml b/lib/management/merge.ml
new file mode 100644
index 0000000..e50d0e6
--- /dev/null
+++ b/lib/management/merge.ml
@@ -0,0 +1,235 @@
+(** 3-way merge of two branch tips using their Lowest Common Ancestor.
+ Walks the history chain to find it, diffs both sides against it,
+ applies merge rules, validates constraints, and persists the result. *)
+
+type conflict =
+ | TupleConflict of { relation: string; hash: Conventions.Hash.t }
+ | SchemaConflict of string
+ | ConstraintConflict of string
+
+type strategy = PreferLeft | PreferRight | RevertToAncestor
+
+type merge_result =
+ | Clean of Database.t
+ | Failed of conflict list
+
+(** Module type for the subset of Manipulation.Make we need. *)
+module type MANIPULATION = sig
+ type storage
+ type error
+ val of_string_error : string -> error
+ val load_database : storage -> Conventions.Hash.t -> (Database.t option, error) result
+ val store_database : storage -> Database.t -> (unit, error) result
+end
+
+module StringSet = Set.Make(String)
+
+(** Walk history to find LCA. First hash in right's ancestry that also appears
+ in left's ancestry set. *)
+let find_lca left_db right_db =
+ let left_ancestors =
+ StringSet.of_list (left_db.Database.hash
+ :: left_db.Database.history)
+ in
+ let right_chain =
+ right_db.Database.hash
+ :: right_db.Database.history
+ in
+ List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain
+
+(** Apply a single relation diff to a database, using strategy on conflicts. *)
+let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff)
+ ~(right_diff : Diff.relation_diff option) : Database.t * conflict list =
+ match left_diff with
+ | Diff.RelationAdded rel ->
+ (* Only left added it; right_diff must be None or same *)
+ (Database.add_relation db ~relation:rel, [])
+
+ | Diff.RelationRemoved name ->
+ (Database.remove_relation db ~name, [])
+
+ | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } ->
+ let conflicts = ref [] in
+ (* Determine the merged relation's Merkle tree *)
+ let base_rel_opt = Database.get_relation db name in
+ (match base_rel_opt with
+ | None -> (db, [])
+ | Some base_rel ->
+ let base_tree = Option.value base_rel.Relation.tree ~default:Merkle.empty in
+ (* Handle schema conflict *)
+ let (resolved_rel, schema_conflict) =
+ if schema_changed then
+ match right_diff with
+ | Some (Diff.RelationModified { schema_changed = true; _ }) ->
+ (* Both changed schema — apply strategy *)
+ let winner = match strategy with
+ | PreferLeft -> Database.get_relation left_db name
+ | PreferRight -> Database.get_relation right_db name
+ | RevertToAncestor -> Some base_rel
+ in
+ (Option.value winner ~default:base_rel, [SchemaConflict name])
+ | _ ->
+ (* Only left changed schema — take left's relation *)
+ let left_rel = Option.value
+ (Database.get_relation left_db name) ~default:base_rel in
+ (left_rel, [])
+ else (base_rel, [])
+ in
+ conflicts := schema_conflict @ !conflicts;
+ (* Apply tuple adds/removes from left *)
+ let merged_tree =
+ List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples
+ in
+ let merged_tree =
+ List.fold_left (fun t h -> Merkle.delete h t) merged_tree removed_tuples
+ in
+ (* Apply tuple adds/removes from right if disjoint *)
+ let merged_tree = match right_diff with
+ | Some (Diff.RelationModified
+ { added_tuples = r_add; removed_tuples = r_rem; _ }) ->
+ (* Detect tuple conflicts: same hash both added and removed *)
+ let left_add = StringSet.of_list added_tuples in
+ let left_rem = StringSet.of_list removed_tuples in
+ let right_add = StringSet.of_list r_add in
+ let right_rem = StringSet.of_list r_rem in
+ let conflict_hashes =
+ StringSet.inter left_add right_rem
+ |> StringSet.union (StringSet.inter left_rem right_add)
+ in
+ if not (StringSet.is_empty conflict_hashes) then begin
+ StringSet.iter (fun h ->
+ conflicts := TupleConflict { relation = name; hash = h } :: !conflicts
+ ) conflict_hashes;
+ (* Resolve conflicting tuples per strategy *)
+ match strategy with
+ | PreferLeft ->
+ (* keep left's merged_tree as-is, ignore conflicting right ops *)
+ let safe_add = StringSet.diff right_add conflict_hashes in
+ let safe_rem = StringSet.diff right_rem conflict_hashes in
+ let t = StringSet.fold (fun h acc -> Merkle.insert h acc) safe_add merged_tree in
+ StringSet.fold (fun h acc -> Merkle.delete h acc) safe_rem t
+ | PreferRight ->
+ (* revert left's conflicting ops, apply right's *)
+ let t = StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree in
+ let t = StringSet.fold (fun h acc -> Merkle.insert h acc) right_add t in
+ StringSet.fold (fun h acc -> Merkle.delete h acc) right_rem t
+ | RevertToAncestor ->
+ (* drop conflicting hashes from merged tree *)
+ StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree
+ end else begin
+ (* Disjoint — union both sides *)
+ let t = List.fold_left (fun acc h -> Merkle.insert h acc) merged_tree r_add in
+ List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem
+ end
+ | _ -> merged_tree
+ in
+ let new_hash = Hashing.hash_relation
+ ~name:resolved_rel.Relation.name
+ ~schema:resolved_rel.Relation.schema
+ ~tree:merged_tree
+ in
+ let updated_rel = { resolved_rel with
+ Relation.tree = Some merged_tree;
+ hash = Some new_hash;
+ } in
+ let new_db = Database.update_relation db ~relation:updated_rel in
+ (new_db, !conflicts))
+
+module Make
+ (Storage : Physical.S)
+ (Manip : MANIPULATION with type storage = Storage.t) =
+struct
+
+ let err s = Error (Manip.of_string_error s)
+
+ (* Load both tips, find the lowest common ancestor, compute the diffs,
+ lookup for right diffs by relation name, start from ancestor and
+ apply all the diffs, apply first the left diffs, then right-only diffs
+ (relations only right touched). If there are no conflicts, persist the
+ merged database, otherwise return Failed, unless a strategy resolved them. *)
+ let merge ~storage ~strategy ~left_tip ~right_tip =
+ match Manip.load_database storage left_tip with
+ | Error e -> Error e
+ | Ok None -> err ("Left tip not found: " ^ left_tip)
+ | Ok (Some left_db) ->
+ match Manip.load_database storage right_tip with
+ | Error e -> Error e
+ | Ok None -> err ("Right tip not found: " ^ right_tip)
+ | Ok (Some right_db) ->
+ match find_lca left_db right_db with
+ | None -> err "No common ancestor found between branches"
+ | Some ancestor_hash ->
+ match Manip.load_database storage ancestor_hash with
+ | Error e -> Error e
+ | Ok None -> err ("Ancestor not found: " ^ ancestor_hash)
+ | Ok (Some ancestor_db) ->
+ let left_diffs = Diff.diff ~ancestor:ancestor_db ~target:left_db in
+ let right_diffs = Diff.diff ~ancestor:ancestor_db ~target:right_db in
+ let right_diff_map =
+ List.fold_left (fun m d ->
+ let key = match d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ Database.RelationMap.add key d m
+ ) Database.RelationMap.empty right_diffs
+ in
+ let (merged_db, all_conflicts) =
+ let (db_after_left, left_conflicts) =
+ List.fold_left (fun (db, conflicts) left_d ->
+ let rel_name = match left_d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ let right_d = Database.RelationMap.find_opt rel_name right_diff_map in
+ let (new_db, cs) =
+ apply_diff db ~strategy ~left_db ~right_db
+ ~left_diff:left_d ~right_diff:right_d
+ in
+ (new_db, cs @ conflicts)
+ ) (ancestor_db, []) left_diffs
+ in
+ let left_names =
+ List.fold_left (fun s d ->
+ let n = match d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ StringSet.add n s
+ ) StringSet.empty left_diffs
+ in
+ let right_only = List.filter (fun d ->
+ let n = match d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ not (StringSet.mem n left_names)
+ ) right_diffs in
+ let (db_final, right_conflicts) =
+ List.fold_left (fun (db, conflicts) right_d ->
+ let (new_db, cs) =
+ apply_diff db ~strategy ~left_db ~right_db
+ ~left_diff:right_d ~right_diff:None
+ in
+ (new_db, cs @ conflicts)
+ ) (db_after_left, left_conflicts) right_only
+ in
+ (db_final, right_conflicts)
+ in
+ let unresolvable = List.filter (function
+ | ConstraintConflict _ -> true
+ | _ -> false
+ ) all_conflicts in
+ if unresolvable <> [] then
+ Ok (Failed unresolvable)
+ else begin
+ match Manip.store_database storage merged_db with
+ | Error e -> Error e
+ | Ok () -> Ok (Clean merged_db)
+ end
+
+end
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
index 2a43b6c..73607fa 100644
--- a/lib/manipulation.ml
+++ b/lib/manipulation.ml
@@ -44,6 +44,8 @@ let build_membership_criteria _schema : (Tuple.t -> bool) =
(** Functor to create manipulation operations with a storage backend *)
module Make (Storage : Management.Physical.S) = struct
type storage = Storage.t
+ type nonrec error = error
+ let of_string_error s = StorageError s
(* Constraint evaluation context *)
diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml
index a277066..4a7241a 100644
--- a/lib/prelude/catalog.ml
+++ b/lib/prelude/catalog.ml
@@ -15,6 +15,8 @@ let attribute_rel_name = catalog_prefix ^ "attribute"
let constraint_rel_name = catalog_prefix ^ "constraint"
let on_rel_name = catalog_prefix ^ "on"
let timing_rel_name = catalog_prefix ^ "timing"
+let branch_rel_name = catalog_prefix ^ "branch"
+let head_rel_name = catalog_prefix ^ "head"
let catalog_relation_names =
[ relation_rel_name
@@ -111,3 +113,4 @@ let build_timing_tuple timing : Tuple.materialized =
Tuple.AttributeMap.singleton "timing"
{ Attribute.value = Obj.magic timing }
}
+
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 07:27:15 +0000