path: root/lib/management/merge.ml

(** 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