Source file deep.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 Result_lwt.Infix
open Cursor

type Error.t += Segments_cannot_be_empty

let () = Error.register_printer (function
    | Segments_cannot_be_empty ->
        Some "Segments cannot be empty"
    | _ -> None)

(** Multi Bud level interface *)
let deep ~go_up ~create_subtrees cur segs f =
  let rec ups cur = function
    | [] -> Ok cur
    | _seg::segs -> parent cur >>? fun cur -> ups cur segs
  in
  let rec aux hist cur = function
    | [] -> assert false
    | [seg] ->
        f cur seg >>? fun (cur, res) ->
        if go_up then
          ups cur hist >>? fun cur ->
          Ok (cur, res)
        else
          Ok (cur, res)
    | seg::segs ->
        (if create_subtrees then subtree_or_create else subtree) cur seg >>? fun cur ->
        aux (seg::hist) cur segs
  in
  (* XXX We may have an Error *)
  if segs = [] then Error Segments_cannot_be_empty
  else aux [] cur segs

let get cur segs =
  deep ~go_up:true ~create_subtrees:false cur segs get

let get_value cur segs =
  deep ~go_up:true ~create_subtrees:false cur segs get_value

let upsert cur segs v =
  deep ~go_up:true ~create_subtrees:true cur segs (fun cur seg ->
      upsert cur seg v >|? fun cur -> cur, ()) >|? fst

let insert cur segs v =
  deep ~go_up:true ~create_subtrees:true cur segs (fun cur seg ->
      insert cur seg v >|? fun cur -> cur, ()) >|? fst

let update cur segs v =
  deep ~go_up:true ~create_subtrees:false cur segs (fun cur seg ->
      update cur seg v >|? fun cur -> cur, ()) >|? fst

let delete cur segs =
  deep ~go_up:true ~create_subtrees:false cur segs (fun cur seg ->
      delete cur seg >|? fun cur -> cur, ()) >|? fst

let delete' cur segs =
  deep ~go_up:true ~create_subtrees:false cur segs (fun cur seg ->
      delete' cur seg >|? fun cur -> cur, ()) >|? fst

(* XXX This function should be deprecated
   because of its semantics complexity *)
let delete_and_clean_empty cur segs =
  deep ~go_up:false ~create_subtrees:false cur segs (fun cur seg ->
      match Cursor.delete cur seg with
      | Ok cur -> Ok (cur, ())
      | Error _ -> Ok (cur, ())) >|? fst
  >>? Cursor.remove_empty_bud

let delete_and_clean_empty' cur segs =
  let rec loop c = function
    | [] -> assert false
    | [seg] -> Cursor.delete c seg
    | seg::segs ->
        subtree c seg
        >>? fun c -> loop c segs
        >>? fun c ->
        let empty = match snd @@ Cursor.view c with
          | Bud (None, _, _) -> true
          | Bud _ -> false
          | _ -> assert false
        in
        Cursor.go_up_to_bud c
        >>? fun c ->
        if empty then Cursor.delete c seg
        else Ok c
  in
  loop cur segs >>? fun c ->
  (* If the Bud at the original point becomes empty,
     the function fails.  Exception: root *)
  match Cursor.view c with
  | Cursor (Top, _, _, _), _ -> Ok c
  | _, Bud (None, _, _) -> Error (Cursor.Write "delete_and_clean_empty': cannot delete the starting point")
  | _, Bud _ -> Ok c
  | _ -> assert false

let create_subtree ~create_subtrees cur segs =
  deep ~go_up:true ~create_subtrees cur segs (fun cur seg ->
      create_subtree cur seg >|? fun cur -> (cur, ())) >|? fst

let subtree cur segs =
  deep ~go_up:false ~create_subtrees:false cur segs (fun cur seg ->
      subtree cur seg >|? fun cur -> (cur, ())) >|? fst

let subtree_or_create ~create_subtrees cur segs =
  deep ~go_up:false ~create_subtrees cur segs (fun cur seg ->
      subtree_or_create cur seg >|? fun cur -> (cur, ())) >|? fst

(* bud copy by link *)
let copy' ?(allow_overwrite=false) ?(only_bud=false) ~create_subtrees ~copy_ref cur segs1 segs2 =
  (* the absolute position *)
  (* find the source *)
  deep ~go_up:false ~create_subtrees:false cur segs1
    (fun cur seg -> access_gen cur seg >>? function
       | Reached (cur, (Bud _ as v)) -> Ok (cur, v) (* Bud is copiable anytime *)
       | Reached (cur, v) when not only_bud -> Ok (cur, v) (* Not only Bud but also internals when only_bud= false *)
       | res -> error_access res) >>? fun (src_cur, v) ->

  (* the absolute source postion and remember it for copy GC optimization *)
  let gpath1 = Cursor.path_of_cursor src_cur in
  (* XXX gsegs1 = segs1 *)
  assert (Segment.equal_list segs1 (Path.to_segments gpath1));

  (* gsegs1 may not exist in the copy_ref *)
  (* we record the copy only if the source segment exists in [copy_ref] *)
  let src_exists =
    match
      deep ~go_up:false ~create_subtrees:false copy_ref (Path.to_segments gpath1)
        (fun cur seg -> access_gen cur seg >>? function
           | Reached (cur, _) -> Ok (cur, true)
           | _ -> Ok (cur, false))
    with
    | Ok (_, b) -> b
    | _ -> false
  in

  let Cursor (trail, n, context, info) = cur in
  let cur =
    _Cursor(trail, n, context,
            if src_exists then { copies= gpath1 :: info.copies }
            else info)
  in

  (* make a link *)
  deep ~go_up:true ~create_subtrees cur segs2
    (fun cur seg ->
       alter cur seg (function
           | Some _ when not allow_overwrite -> Error (Cursor.Write "a node already presents for this segment")
           | _ -> Ok (View v)
         ) >>? fun cur ->
       Ok (cur, ())) >|? fst

(* bud copy by link *)
let copy ?allow_overwrite ~create_subtrees cur segs1 segs2 =
  copy' ?allow_overwrite ~only_bud:true ~create_subtrees ~copy_ref:cur cur segs1 segs2

let link n cur segs =
  deep ~go_up:true ~create_subtrees:true
    cur
    segs
    (fun c seg ->
       (* XXX this alter has once inserted Disk (Maybe_Extender)
          under an extender and crashed program.

          We here workaround this problem to force to view [n]
       *)
       let Cursor (_, _, context, _) = c in
       (* [n] must be under [context] *)
       let v = Node_storage.view context n in
       let n = Node_type.View v in
       alter c seg (function
           | Some _ -> assert false
           | None -> Ok n) >|? fun c -> (c, ()))
  >|? fst

let alter cur segs f =
  deep ~go_up:true ~create_subtrees:true
    cur
    segs
    (fun c seg -> alter c seg f >|? fun c -> (c, ()))
  >|? fst