Source file diff.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019,2020 DaiLambda, Inc. <contact@dailambda.jp>            *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Segment

open Node_type

(* strings are for debugging purpose *)
type t =
  | Add of node * Segs.t (* node cannot be an Extender *)
  | Del of Segs.t
  | CleanBud of Segs.t
  | ModLeaf of node * Value.t * Segs.t

let pp ppf =
  let open Format in
  let f fmt = fprintf ppf fmt in
  let i ppf n =
    match Node_type.index n with
    | None -> pp_print_string ppf "none"
    | Some i -> Index.pp ppf i
  in
  function
  | Add (n, segs) ->
      f "Add %a %s" i n (Segs.to_string segs)
  | Del segs ->
      f "Del %s" (Segs.to_string segs)
  | CleanBud segs ->
      f "CleanBud %s" (Segs.to_string segs)
  | ModLeaf (n2, _v, segs) ->
      f "ModLeaf %a %s" i n2 (Segs.to_string segs)

let apply c diff = match diff with
  | Add (n, segs) -> Deep.link n c @@ Segment.Segs.to_segments segs
  | Del segs -> Deep.delete' c @@ Segment.Segs.to_segments segs
  | CleanBud segs ->
      let segs = Segment.Segs.to_segments (Segment.Segs.push_bud segs) in
      Deep.delete' c segs
  | ModLeaf (_, v, segs) ->
      Deep.update c (Segment.Segs.to_segments segs) v

let apply c diff = match apply c diff with
  | Ok res -> Ok res
  | Error e ->
      Debug.save_cursor_to_dot "diff.dot" c;
      let c' = Cursor.Cursor_storage.read_fully ~reset_index:false c in
      Debug.save_cursor_to_dot "diff2.dot" c';
      Format.eprintf "Error: %a %a@." Error.pp e pp diff;
      Error e

let apply_and_check ctxt n1 n2 diffs =
  let c = Cursor.(_Cursor(_Top, n1, ctxt, Info.empty)) in
  match Result.fold_leftM apply c diffs with
  | Error e ->
      Format.eprintf "error %a@." Error.pp e; assert false
  | Ok (Cursor(Top, n2', ctxt, _)) ->
      let compute = Node.compute_hash ctxt in
      let _, nh = compute n2 in
      let _, nh' = compute n2' in
      assert (nh = nh')
  | Ok _ -> assert false

let diff ctxt n1 n2 =
  let rec loop diff frontiers =
    match frontiers with
    | [] -> diff
    | (n1, n2, segs, rev_sides)::frontiers ->
        let add (n, segs) =
          if rev_sides = [] then Add (n, segs)
          else
            match Node_storage.view ctxt n with
            | Extender (seg, n, _, _) ->
                Add (n, Segs.append_seg segs seg)
            | _ -> Add (n, segs)
        in
        let del (n, segs) =
          if rev_sides = [] then Del segs
          else
            match Node_storage.view ctxt n with
            | Extender (seg, _n, _, _) ->
                Del (Segs.append_seg segs seg)
            | _ -> Del segs
        in
        let loop' newdiffs newfrontiers =
          loop (newdiffs @ diff) (newfrontiers @ frontiers)
        in
        match n1, n2 with
        | Disk _, Disk _ when n1 = n2 -> loop' [] []
        | _ ->
            let v1 = Node_storage.view ctxt n1 in
            let v2 = Node_storage.view ctxt n2 in
            let i1 = Node_type.index n1 in
            let i2 = Node_type.index n2 in
            match i1, i2 with
            | Some i1, Some i2 when i1 = i2 -> loop' [] []
            | _ ->
                let hp1o = Node_type.hash_prefix_of_view v1 in
                let hp2o = Node_type.hash_prefix_of_view v2 in
                let hash_prefix_same = match hp1o, hp2o with
                  | Some hp1, Some hp2 -> hp1 = hp2
                  | _ -> false
                in
                match v1, v2 with
                | Leaf _, Leaf _
                | Bud _, Bud _
                | Internal _, Internal _ when hash_prefix_same -> loop' [] []
                | Extender (seg1,_,_,_), Extender (seg2,_,_,_) when hash_prefix_same && Segment.equal seg1 seg2 -> loop' [] []

                | Bud (None, _, _), Bud (None, _, _) -> loop' [] []

                | Leaf (val1, _, _), Leaf (val2, _, _) when val1 = val2 -> loop' [] []

                | Leaf (_, _, _), Leaf (val2, _, _) ->
                    loop' [ ModLeaf (View v2, val2, segs) ] []

                | Bud (Some n1, _, _), Bud (Some n2, _, _) ->
                    loop' [] [ (n1, n2, Segs.push_bud segs, []) ]

                | Bud (None, _, _), Bud (Some n, _, _) ->
                    loop' [ add (n, Segs.push_bud segs) ] []

                | Bud (Some _n1, _, _), Bud (None, _, _) ->
                    (* Bud itself is kept. *)
                    loop' [ CleanBud segs ] []

                | Internal (n1l, n1r, _, _), Internal (n2l, n2r, _, _) ->
                    loop' [] [ (n1l, n2l, Segs.add_side segs Left, [])
                             ; (n1r, n2r, Segs.add_side segs Right, [] )
                             ]

                | Extender (seg1, n1, _, _), Extender (seg2, n2, _, _) when equal seg1 seg2 ->
                    loop' [] [ (n1, n2, Segs.append_seg segs seg1, []) ]

                | Bud _, (Leaf _ | Internal _ | Extender _)
                | Leaf _, (Bud _ | Internal _ | Extender _)
                | (Internal _ | Extender _), (Bud _ | Leaf _) ->
                    loop' [ del (n1, segs); add (n2, segs) ] []

                | Extender (seg1, n1, _, h1), Extender (seg2, n2, _, h2) ->
                    let common, seg1', seg2' = Segment.common_prefix seg1 seg2 in
                    if Segment.is_empty common then
                      loop' [ del (View v1, segs)
                            ; add (View v2, segs)
                            ] []
                    else
                      let n1' =
                        if Segment.is_empty seg1' then n1
                        else View (_Extender (seg1', n1, Not_Indexed, h1))
                      in
                      let n2' =
                        if Segment.is_empty seg2' then n2
                        else View (_Extender (seg2', n2, Not_Indexed, h2))
                      in
                      loop' []
                        [ (n1', n2', Segs.append_seg segs common,
                           List.rev_append (Segment.to_sides common) rev_sides) ]

                | Internal (n1l, n1r, _, _), Extender (seg, n2, _, h) ->
                    begin match cut seg with
                      | None -> assert false
                      | Some (Left, seg) ->
                          let n2 =
                            if is_empty seg then n2
                            else View (_Extender (seg, n2, Not_Indexed, h))
                          in
                          loop' [ del (n1r, Segs.add_side segs Right) ]
                            [ (n1l, n2, Segs.add_side segs Left, Left :: rev_sides) ]
                      | Some (Right, seg) ->
                          let n2 =
                            if is_empty seg then n2
                            else View (_Extender (seg, n2, Not_Indexed, h))
                          in
                          loop' [ del (n1l, Segs.add_side segs Left) ]
                            [ (n1r, n2, Segs.add_side segs Right, Right :: rev_sides ) ]
                    end

                | Extender (seg, n1, _, h), Internal (n2l, n2r, _, _) ->
                    begin match cut seg with
                      | None -> assert false
                      | Some (Left, seg) ->
                          let n1 =
                            if is_empty seg then n1
                            else View (_Extender (seg, n1, Not_Indexed, h))
                          in
                          loop' [ add (n2r, Segs.add_side segs Right) ]
                            [ (n1, n2l, Segs.add_side segs Left, Left :: rev_sides) ]
                      | Some (Right, seg) ->
                          let n1 =
                            if is_empty seg then n1
                            else View (_Extender (seg, n1, Not_Indexed, h))
                          in
                          loop' [ add (n2l, Segs.add_side segs Left) ]
                            [ (n1, n2r, Segs.add_side segs Right, Right :: rev_sides) ]
                    end
  in
  loop [] [(n1, n2, Segs.empty', [])]

let reset_for_another_context context =
  let load = Node_storage.read_node_fully ~reset_index:true context in
  function
  | Add (n, segs) -> Add (load n, segs)
  | Del segs -> Del segs
  | CleanBud segs -> CleanBud segs
  | ModLeaf (n2, v, segs) -> ModLeaf (load n2, v, segs)

let reset_for_another_context' ~src ~dst = function
  | Add (n, segs) -> Add (Node_storage.change_context ~src ~dst n, segs)
  | Del segs -> Del segs
  | CleanBud segs -> CleanBud segs
  | ModLeaf (n2, v, segs) -> ModLeaf (Node_storage.change_context ~src ~dst n2, v, segs)