diff options
Diffstat (limited to 'lib/management/merge.ml')
| -rw-r--r-- | lib/management/merge.ml | 435 |
1 files changed, 243 insertions, 192 deletions
diff --git a/lib/management/merge.ml b/lib/management/merge.ml index e50d0e6..d30545a 100644 --- a/lib/management/merge.ml +++ b/lib/management/merge.ml @@ -1,40 +1,37 @@ -(** 3-way merge of two branch tips using their Lowest Common Ancestor. - Walks the history chain to find it, diffs both sides against it, - applies merge rules, validates constraints, and persists the result. *) +(** 3-way merge of two branch tips using their Lowest Common Ancestor. Walks the + history chain to find it, diffs both sides against it, applies merge rules, + validates constraints, and persists the result. *) type conflict = - | TupleConflict of { relation: string; hash: Conventions.Hash.t } - | SchemaConflict of string + | TupleConflict of { relation : string; hash : Conventions.Hash.t } + | SchemaConflict of string | ConstraintConflict of string type strategy = PreferLeft | PreferRight | RevertToAncestor - -type merge_result = - | Clean of Database.t - | Failed of conflict list +type merge_result = Clean of Database.t | Failed of conflict list (** Module type for the subset of Manipulation.Make we need. *) module type MANIPULATION = sig type storage type error - val of_string_error : string -> error - val load_database : storage -> Conventions.Hash.t -> (Database.t option, error) result + + val of_string_error : string -> error + + val load_database : + storage -> Conventions.Hash.t -> (Database.t option, error) result + val store_database : storage -> Database.t -> (unit, error) result end -module StringSet = Set.Make(String) +module StringSet = Set.Make (String) (** Walk history to find LCA. First hash in right's ancestry that also appears in left's ancestry set. *) let find_lca left_db right_db = let left_ancestors = - StringSet.of_list (left_db.Database.hash - :: left_db.Database.history) - in - let right_chain = - right_db.Database.hash - :: right_db.Database.history + StringSet.of_list (left_db.Database.hash :: left_db.Database.history) in + let right_chain = right_db.Database.hash :: right_db.Database.history in List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain (** Apply a single relation diff to a database, using strategy on conflicts. *) @@ -42,104 +39,140 @@ let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff) ~(right_diff : Diff.relation_diff option) : Database.t * conflict list = match left_diff with | Diff.RelationAdded rel -> - (* Only left added it; right_diff must be None or same *) - (Database.add_relation db ~relation:rel, []) - - | Diff.RelationRemoved name -> - (Database.remove_relation db ~name, []) - - | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } -> - let conflicts = ref [] in - (* Determine the merged relation's Merkle tree *) - let base_rel_opt = Database.get_relation db name in - (match base_rel_opt with - | None -> (db, []) - | Some base_rel -> - let base_tree = Option.value base_rel.Relation.tree ~default:Merkle.empty in - (* Handle schema conflict *) - let (resolved_rel, schema_conflict) = - if schema_changed then - match right_diff with - | Some (Diff.RelationModified { schema_changed = true; _ }) -> - (* Both changed schema — apply strategy *) - let winner = match strategy with - | PreferLeft -> Database.get_relation left_db name - | PreferRight -> Database.get_relation right_db name - | RevertToAncestor -> Some base_rel - in - (Option.value winner ~default:base_rel, [SchemaConflict name]) - | _ -> - (* Only left changed schema — take left's relation *) - let left_rel = Option.value - (Database.get_relation left_db name) ~default:base_rel in - (left_rel, []) - else (base_rel, []) - in - conflicts := schema_conflict @ !conflicts; - (* Apply tuple adds/removes from left *) - let merged_tree = - List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples - in - let merged_tree = - List.fold_left (fun t h -> Merkle.delete h t) merged_tree removed_tuples - in - (* Apply tuple adds/removes from right if disjoint *) - let merged_tree = match right_diff with - | Some (Diff.RelationModified + (* Only left added it; right_diff must be None or same *) + (Database.add_relation db ~relation:rel, []) + | Diff.RelationRemoved name -> (Database.remove_relation db ~name, []) + | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } + -> ( + let conflicts = ref [] in + (* Determine the merged relation's Merkle tree *) + let base_rel_opt = Database.get_relation db name in + match base_rel_opt with + | None -> (db, []) + | Some base_rel -> + let base_tree = + Option.value base_rel.Relation.tree ~default:Merkle.empty + in + (* Handle schema conflict *) + let resolved_rel, schema_conflict = + if schema_changed then + match right_diff with + | Some (Diff.RelationModified { schema_changed = true; _ }) -> + (* Both changed schema — apply strategy *) + let winner = + match strategy with + | PreferLeft -> Database.get_relation left_db name + | PreferRight -> Database.get_relation right_db name + | RevertToAncestor -> Some base_rel + in + ( Option.value winner ~default:base_rel, + [ SchemaConflict name ] ) + | _ -> + (* Only left changed schema — take left's relation *) + let left_rel = + Option.value + (Database.get_relation left_db name) + ~default:base_rel + in + (left_rel, []) + else (base_rel, []) + in + conflicts := schema_conflict @ !conflicts; + (* Apply tuple adds/removes from left *) + let merged_tree = + List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples + in + let merged_tree = + List.fold_left + (fun t h -> Merkle.delete h t) + merged_tree removed_tuples + in + (* Apply tuple adds/removes from right if disjoint *) + let merged_tree = + match right_diff with + | Some + (Diff.RelationModified { added_tuples = r_add; removed_tuples = r_rem; _ }) -> - (* Detect tuple conflicts: same hash both added and removed *) - let left_add = StringSet.of_list added_tuples in - let left_rem = StringSet.of_list removed_tuples in - let right_add = StringSet.of_list r_add in - let right_rem = StringSet.of_list r_rem in - let conflict_hashes = - StringSet.inter left_add right_rem - |> StringSet.union (StringSet.inter left_rem right_add) - in - if not (StringSet.is_empty conflict_hashes) then begin - StringSet.iter (fun h -> - conflicts := TupleConflict { relation = name; hash = h } :: !conflicts - ) conflict_hashes; - (* Resolve conflicting tuples per strategy *) - match strategy with - | PreferLeft -> - (* keep left's merged_tree as-is, ignore conflicting right ops *) - let safe_add = StringSet.diff right_add conflict_hashes in - let safe_rem = StringSet.diff right_rem conflict_hashes in - let t = StringSet.fold (fun h acc -> Merkle.insert h acc) safe_add merged_tree in - StringSet.fold (fun h acc -> Merkle.delete h acc) safe_rem t - | PreferRight -> - (* revert left's conflicting ops, apply right's *) - let t = StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree in - let t = StringSet.fold (fun h acc -> Merkle.insert h acc) right_add t in - StringSet.fold (fun h acc -> Merkle.delete h acc) right_rem t - | RevertToAncestor -> - (* drop conflicting hashes from merged tree *) - StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree - end else begin - (* Disjoint — union both sides *) - let t = List.fold_left (fun acc h -> Merkle.insert h acc) merged_tree r_add in - List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem - end - | _ -> merged_tree - in - let new_hash = Hashing.hash_relation - ~name:resolved_rel.Relation.name - ~schema:resolved_rel.Relation.schema - ~tree:merged_tree - in - let updated_rel = { resolved_rel with - Relation.tree = Some merged_tree; - hash = Some new_hash; - } in - let new_db = Database.update_relation db ~relation:updated_rel in - (new_db, !conflicts)) + (* Detect tuple conflicts: same hash both added and removed *) + let left_add = StringSet.of_list added_tuples in + let left_rem = StringSet.of_list removed_tuples in + let right_add = StringSet.of_list r_add in + let right_rem = StringSet.of_list r_rem in + let conflict_hashes = + StringSet.inter left_add right_rem + |> StringSet.union (StringSet.inter left_rem right_add) + in + if not (StringSet.is_empty conflict_hashes) then begin + StringSet.iter + (fun h -> + conflicts := + TupleConflict { relation = name; hash = h } + :: !conflicts) + conflict_hashes; + (* Resolve conflicting tuples per strategy *) + match strategy with + | PreferLeft -> + (* keep left's merged_tree as-is, ignore conflicting right ops *) + let safe_add = StringSet.diff right_add conflict_hashes in + let safe_rem = StringSet.diff right_rem conflict_hashes in + let t = + StringSet.fold + (fun h acc -> Merkle.insert h acc) + safe_add merged_tree + in + StringSet.fold + (fun h acc -> Merkle.delete h acc) + safe_rem t + | PreferRight -> + (* revert left's conflicting ops, apply right's *) + let t = + StringSet.fold + (fun h acc -> Merkle.delete h acc) + conflict_hashes merged_tree + in + let t = + StringSet.fold + (fun h acc -> Merkle.insert h acc) + right_add t + in + StringSet.fold + (fun h acc -> Merkle.delete h acc) + right_rem t + | RevertToAncestor -> + (* drop conflicting hashes from merged tree *) + StringSet.fold + (fun h acc -> Merkle.delete h acc) + conflict_hashes merged_tree + end + else begin + (* Disjoint — union both sides *) + let t = + List.fold_left + (fun acc h -> Merkle.insert h acc) + merged_tree r_add + in + List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem + end + | _ -> merged_tree + in + let new_hash = + Hashing.hash_relation ~name:resolved_rel.Relation.name + ~schema:resolved_rel.Relation.schema ~tree:merged_tree + in + let updated_rel = + { + resolved_rel with + Relation.tree = Some merged_tree; + hash = Some new_hash; + } + in + let new_db = Database.update_relation db ~relation:updated_rel in + (new_db, !conflicts)) module Make (Storage : Physical.S) - (Manip : MANIPULATION with type storage = Storage.t) = + (Manip : MANIPULATION with type storage = Storage.t) = struct - let err s = Error (Manip.of_string_error s) (* Load both tips, find the lowest common ancestor, compute the diffs, @@ -151,85 +184,103 @@ struct match Manip.load_database storage left_tip with | Error e -> Error e | Ok None -> err ("Left tip not found: " ^ left_tip) - | Ok (Some left_db) -> - match Manip.load_database storage right_tip with - | Error e -> Error e - | Ok None -> err ("Right tip not found: " ^ right_tip) - | Ok (Some right_db) -> - match find_lca left_db right_db with - | None -> err "No common ancestor found between branches" - | Some ancestor_hash -> - match Manip.load_database storage ancestor_hash with - | Error e -> Error e - | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) - | Ok (Some ancestor_db) -> - let left_diffs = Diff.diff ~ancestor:ancestor_db ~target:left_db in - let right_diffs = Diff.diff ~ancestor:ancestor_db ~target:right_db in - let right_diff_map = - List.fold_left (fun m d -> - let key = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - Database.RelationMap.add key d m - ) Database.RelationMap.empty right_diffs - in - let (merged_db, all_conflicts) = - let (db_after_left, left_conflicts) = - List.fold_left (fun (db, conflicts) left_d -> - let rel_name = match left_d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - let right_d = Database.RelationMap.find_opt rel_name right_diff_map in - let (new_db, cs) = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:left_d ~right_diff:right_d - in - (new_db, cs @ conflicts) - ) (ancestor_db, []) left_diffs - in - let left_names = - List.fold_left (fun s d -> - let n = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - StringSet.add n s - ) StringSet.empty left_diffs - in - let right_only = List.filter (fun d -> - let n = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - not (StringSet.mem n left_names) - ) right_diffs in - let (db_final, right_conflicts) = - List.fold_left (fun (db, conflicts) right_d -> - let (new_db, cs) = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:right_d ~right_diff:None - in - (new_db, cs @ conflicts) - ) (db_after_left, left_conflicts) right_only - in - (db_final, right_conflicts) - in - let unresolvable = List.filter (function - | ConstraintConflict _ -> true - | _ -> false - ) all_conflicts in - if unresolvable <> [] then - Ok (Failed unresolvable) - else begin - match Manip.store_database storage merged_db with - | Error e -> Error e - | Ok () -> Ok (Clean merged_db) - end - + | Ok (Some left_db) -> ( + match Manip.load_database storage right_tip with + | Error e -> Error e + | Ok None -> err ("Right tip not found: " ^ right_tip) + | Ok (Some right_db) -> ( + match find_lca left_db right_db with + | None -> err "No common ancestor found between branches" + | Some ancestor_hash -> ( + match Manip.load_database storage ancestor_hash with + | Error e -> Error e + | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) + | Ok (Some ancestor_db) -> + let left_diffs = + Diff.diff ~ancestor:ancestor_db ~target:left_db + in + let right_diffs = + Diff.diff ~ancestor:ancestor_db ~target:right_db + in + let right_diff_map = + List.fold_left + (fun m d -> + let key = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + Database.RelationMap.add key d m) + Database.RelationMap.empty right_diffs + in + let merged_db, all_conflicts = + let db_after_left, left_conflicts = + List.fold_left + (fun (db, conflicts) left_d -> + let rel_name = + match left_d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + let right_d = + Database.RelationMap.find_opt rel_name + right_diff_map + in + let new_db, cs = + apply_diff db ~strategy ~left_db ~right_db + ~left_diff:left_d ~right_diff:right_d + in + (new_db, cs @ conflicts)) + (ancestor_db, []) left_diffs + in + let left_names = + List.fold_left + (fun s d -> + let n = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + StringSet.add n s) + StringSet.empty left_diffs + in + let right_only = + List.filter + (fun d -> + let n = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + not (StringSet.mem n left_names)) + right_diffs + in + let db_final, right_conflicts = + List.fold_left + (fun (db, conflicts) right_d -> + let new_db, cs = + apply_diff db ~strategy ~left_db ~right_db + ~left_diff:right_d ~right_diff:None + in + (new_db, cs @ conflicts)) + (db_after_left, left_conflicts) + right_only + in + (db_final, right_conflicts) + in + let unresolvable = + List.filter + (function ConstraintConflict _ -> true | _ -> false) + all_conflicts + in + if unresolvable <> [] then Ok (Failed unresolvable) + else begin + match Manip.store_database storage merged_db with + | Error e -> Error e + | Ok () -> Ok (Clean merged_db) + end))) end |