Source file cursor.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Arthur Breitman <arthur.breitman+nospam@tezos.com>     *)
(* Copyright (c) 2019 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)
(** Cursor (zipper) based tree operations *)

open Utils
open Lwt.Syntax
open Result_lwt.Syntax
open Result_lwt.Infix

open Node_type

(* Trail and cursor *)

type modified =
  | Modified
  | Unmodified of indexed * hashed

type trail =
  | Top
  | Left of (* we took the left branch of an internal node *)
      trail
      * node
      * modified

  | Right of (* we took the right branch of an internal node *)
      node
      * trail
      * modified

  | Budded of
      trail
      * modified

  | Extended of
      trail
      * Segment.t
      * modified
  (* not the use of the "extender" and "not extender" type to enforce
     that two extenders cannot follow each other *)

type Error.t +=
  | Cursor_invariant of string
  | Move of string

let () = Error.register_printer @@ function
  | Cursor_invariant s -> Some ("Cursor: " ^ s)
  | Move s -> Some s
  | _ -> None

let error_cursor_invariant s = Error (Cursor_invariant s)

module Invariant_trail : sig
  val check : trail -> trail
end = struct
  let trail_shape_invariant = function
    | Extended (Extended _, _, _) -> error_cursor_invariant "Extended: cannot have Extended"
    | Extended (_, seg, _) when Segment.is_empty seg -> error_cursor_invariant "Extended: invalid empty segment"
    | _ -> Ok ()

  let trail_modified_invariant = function
    | Top -> Ok ()
    | Left (_, n, Unmodified (ir, hit)) ->
        begin match ir with
          | Not_Indexed -> Ok ()
          | Indexed _ when indexed n -> Ok ()
          | Indexed _ -> error_cursor_invariant "Left: invalid Indexed"
        end >>? fun () ->
        begin match hit with
          | Hashed _ when hashed n -> Ok ()
          | Hashed _ -> error_cursor_invariant "Left: invalid Hashed"
          | Not_Hashed -> Ok ()
        end
    | Left (_, _, Modified) -> Ok ()
    | Right (n, _, Unmodified (ir, hit)) ->
        begin match ir with
          | Not_Indexed -> Ok ()
          | Indexed _ when indexed n -> Ok ()
          | Indexed _ -> error_cursor_invariant "Right: invalid Indexed"
        end >>? fun () ->
        begin match hit with
          | Hashed _ when hashed n -> Ok ()
          | Hashed _ -> error_cursor_invariant "Right: invalid Hashed"
          | Not_Hashed -> Ok ()
        end
    | Right (_, _, Modified) -> Ok ()
    | Budded (_, Unmodified (ir, _hit)) ->
        begin match ir with
          | Indexed _ | Not_Indexed -> Ok ()
        end
    | Budded (_, Modified) -> Ok ()
    | Extended (_, _, Unmodified (ir, _hit)) ->
        begin match ir with
          | Indexed _ | Not_Indexed -> Ok ()
        end
    | Extended (_, _, Modified) -> Ok ()

  let trail_index_and_hash_invariant = function
    | Top -> Ok ()
    | Left (_, _, Unmodified (Indexed _, Not_Hashed))
    | Right (_, _, Unmodified (Indexed _, Not_Hashed))
    | Budded (_, Unmodified (Indexed _, Not_Hashed))
    | Extended (_, _, Unmodified (Indexed _, Not_Hashed)) -> error_cursor_invariant "Trail: Indexed with Not_Hashed"
    | _ -> Ok ()

  let trail_invariant t =
    trail_shape_invariant t >>? fun () ->
    trail_modified_invariant t >>? fun () ->
    trail_index_and_hash_invariant t

  let _check t =
    match trail_invariant t with
    | Ok _ -> t
    | Error s -> Error.raise s

  let check x = x
end

let _Top = Top
let _Left (t, n, mr)     = Invariant_trail.check @@ Left (t, n, mr)
let _Right (n, t, mr)    = Invariant_trail.check @@ Right (n, t, mr)
let _Budded (t, mr)      = Invariant_trail.check @@ Budded (t, mr)
let _Extended (t, s, mr) = Invariant_trail.check @@ Extended (t, s, mr)

type info = Info.t

type cursor =
    Cursor of trail
              * node
              * Context.t
              * info
  (* The cursor, also known as a zipper combines the information contained in a
     trail and a subtree to represent an edit point within a tree. This is a
     functional data structure that represents the program point in a function
     that modifies a tree. We use an existential type that keeps the .mli sane
     and enforces the most important: that the hole tags match between the trail
     and the Node *)

type t = cursor

let context (Cursor (_, _, context, _)) = context

let get_storage (Cursor (_, _, context, _)) = Context.get_storage context

module Invariant_cursor : sig
  val check : t -> t
end = struct
  let cursor_invariant (Cursor (trail, n, c, _)) =
    match trail with
    | Top ->
        begin match Node_storage.view c n with
          | Bud _ -> Ok ()
          | v ->
              Log.fatal "@[<v2>Cursor: Top has no Bud:@ %a@]" Node_type.pp (View v);
              Error "Cursor: Top has no Bud"
        end
    | Left (_, n', Unmodified (ir, hit)) ->
        begin match ir with
          | Not_Indexed -> Ok ()
          | Indexed _ when indexed n && indexed n' -> Ok ()
          | Indexed _ -> Error "Cursor: invalid Indexed"
        end >>? fun () ->
        begin match hit with
          | Hashed _ when hashed n -> Ok ()
          | Hashed _ -> Error "Cursor: invalid Hashed"
          | Not_Hashed -> Ok ()
        end
    | Left (_, _, Modified) -> Ok ()
    | Right (n', _, Unmodified (ir, hit)) ->
        begin match ir with
          | Not_Indexed -> Ok ()
          | Indexed _ when indexed n && indexed n' -> Ok ()
          | Indexed _ -> Error "Cursor: invalid Indexed"
        end >>? fun () ->
        begin match hit with
          | Hashed _ when hashed n -> Ok ()
          | Hashed _ -> Error "Cursor: invalid Hashed"
          | Not_Hashed -> Ok ()
        end
    | Right (_, _, Modified) -> Ok ()
    | Budded (_, Unmodified (ir, _hit)) ->
        begin match ir with
          | Indexed _ when indexed n -> Ok ()
          | Indexed _ -> Error "Budded: invalid Indexed"
          | Not_Indexed -> Ok ()
        end
    | Budded (_, Modified) -> Ok ()
    | Extended (_, _, Unmodified (ir, hit)) ->
        begin match ir with
          | Indexed _ when indexed n -> Ok ()
          | Indexed _ -> Error "Extended: invalid Indexed"
          | Not_Indexed -> Ok ()
        end >>? fun () ->
        begin match hit with
          | Hashed _ when hashed n -> Ok ()
          | Hashed _ -> Error "Extended: invalid Hashed"
          | Not_Hashed -> Ok ()
        end
    | Extended (_, _, Modified) -> Ok ()

  let _check c =
    match cursor_invariant c with
    | Ok _ -> c
    | Error s -> failwith s

  let check x = x
end

let _Cursor (t, n, c, i) = Invariant_cursor.check @@ Cursor (t, n, c, i)

let path_of_trail trail =
  let rec aux (xs, xss) = function
    | Top ->
        (* The previous trail must be Budded, therefore xs must be empty *)
        assert (xs = []); Path.of_segments xss
    | Budded (tr, _) -> aux ([], Segment.unfat xs::xss) tr
    | Left (tr, _, _) -> aux (`Left::xs, xss) tr
    | Right (_, tr, _) -> aux (`Right::xs, xss) tr
    | Extended (tr, seg, _) -> aux (`Segment seg::xs, xss) tr
  in
  aux ([], []) trail

let path_of_cursor (Cursor (trail, _, _, _)) = path_of_trail trail

let local_seg_of_trail trail =
  let rec aux xs = function
    | Top -> Segment.unfat xs
    | Budded (_, _) -> Segment.unfat xs
    | Left (tr, _, _) -> aux (`Left :: xs) tr
    | Right (_, tr, _) -> aux (`Right :: xs) tr
    | Extended (tr, seg, _) -> aux (`Segment seg :: xs) tr
  in
  aux [] trail

let local_seg_of_cursor (Cursor (trail, _, _, _)) = local_seg_of_trail trail

let dot_of_cursor_ref : (t -> string) ref = ref (fun _ -> assert false)

let attach' = function
  | Top | Left (_, _, Modified) | Right (_, _, Modified)
  | Budded (_, Modified) | Extended (_, _, Modified) as t -> t
  | Left (prev_trail, right, _) ->
      _Left (prev_trail, right, Modified)
  | Right (left, prev_trail, _) ->
      _Right (left, prev_trail, Modified)
  | Budded (prev_trail, _) ->
      _Budded (prev_trail, Modified)
  | Extended (prev_trail, segment, _) ->
      _Extended (prev_trail, segment, Modified)

let attach trail node context i =
  (* Attaches a node to a trail even if the indexing type and hashing type is
     incompatible with the trail by tagging the modification. Extender types
     still have to match. *)
  _Cursor (attach' trail, node, context, i)

let view_cursor (Cursor (trail, n, context, i)) =
  let v = Node_storage.view context n in
  (_Cursor (trail, View v, context, i), v)

let index (Cursor (_, n, _, _)) = Node_type.index n

let go_below_bud (Cursor (trail, n, context, i)) =
  (* This function expects a cursor positionned on a bud and moves it one step below. *)
  match Node_storage.view context n with
  | Bud (None, _, _) -> Ok None
  | Bud (Some below, indexed, hashed) ->
      Ok (Some (_Cursor (
          _Budded (trail, Unmodified (indexed, hashed)), below,  context, i)))
  | _ -> Error (Move "Attempted to navigate below a bud, but got a different kind of node.")

let go_side side (Cursor (trail, n, context, i)) =
  (* Move the cursor down left or down right in the tree, assuming we are on an internal node. *)
  match Node_storage.view context n with
  | Internal (l, r, indexed, hashed) ->
      Ok (match side with
          | Segment.Right ->
              _Cursor (_Right (l, trail,
                               Unmodified (indexed, hashed)),
                       r, context, i)
          | Segment.Left ->
              _Cursor (_Left (trail, r,
                              Unmodified (indexed, hashed)),
                       l, context, i))
  | _ -> Error (Move "Attempted to navigate right or left of a non internal node")

let go_down_extender (Cursor (trail, n, context, i)) =
  (* Move the cursor down the extender it points to. *)
  match Node_storage.view context n with
  | Extender (segment, below, indexed, hashed) ->
      Ok (_Cursor (_Extended (trail, segment,
                              Unmodified (indexed, hashed)),
                   below, context, i))
  | _ -> Error (Move "Attempted to go down an extender but did not find an extender")

(* Go up 1 level of tree.
   Note that this can be more than 1 levels in segments,
   because of the extenders
*)
let go_up' top f trail node = match trail with
  | Top -> top node
  | Left (prev_trail, right, Unmodified (indexed, hashed)) ->
      let new_node = View (_Internal (node, right, indexed, hashed)) in
      f prev_trail new_node
  | Right (left, prev_trail, Unmodified (indexed, hashed)) ->
      let new_node = View (_Internal (left, node, indexed, hashed)) in
      f prev_trail new_node
  | Budded (prev_trail, Unmodified (indexed, hashed)) ->
      let new_node = View (_Bud (Some node, indexed, hashed)) in
      f prev_trail new_node
  | Extended (prev_trail, segment, Unmodified (indexed, hashed)) ->
      let new_node = View (_Extender (segment, node, indexed, hashed)) in
      f prev_trail new_node

  (* Modified cases. *)
  | Left (prev_trail, right, Modified) ->
      let internal = new_internal node right in
      let prev_trail = attach' prev_trail in
      f prev_trail internal
  | Right (left, prev_trail, Modified) ->
      let internal = new_internal left node in
      let prev_trail = attach' prev_trail in
      f prev_trail internal
  | Budded (prev_trail, Modified) ->
      let bud = new_bud @@ Some node in
      let prev_trail = attach' prev_trail in
      f prev_trail bud
  | Extended (prev_trail, segment, Modified) ->
      let extender = new_extender segment node in
      let prev_trail = attach' prev_trail in
      f prev_trail extender
[@@inline]

let move_above_top = Move "cannot go above top"

let go_up (Cursor (trail, node, context, i)) =
  go_up'
    (fun _ -> Error move_above_top)
    (fun trail node -> Ok (_Cursor (trail, node, context, i)))
    trail
    node
[@@inlined]

let go_top (Cursor (trail, node, context, index)) =
  let rec aux trail node =
    (go_up' [@inlined])
      (fun node -> _Cursor (_Top, node, context, index))
      aux trail node in
  aux trail node

(* This does not go up if the cursor points a Bud already *)
let go_up_to_a_bud (Cursor (trail, node, context, i)) =
  let rec aux (trail, node) =
    let v = Node_storage.view context node in
    match v with
    | Bud _ -> Ok (_Cursor (trail, View v, context, i)) (* already at a bud *)
    | _ ->
        go_up'
          (fun _ -> Error move_above_top)
          (fun trail node -> Ok (trail, node))
          trail
          (View v) >>? aux in
  aux (trail, node)

(* This goes up at least 1 level, even if the cursor points a Bud already *)
let go_up_to_bud (Cursor (trail, node, ctxt, i)) =
  let rec aux trail node =
    match trail with
    | Budded _ ->
        go_up'
          (fun _ -> Error move_above_top)
          (fun trail node -> Ok (_Cursor (trail, node, ctxt, i)))
          trail
          node
    | _ ->
        go_up'
          (fun _ -> Error move_above_top)
          aux
          trail
          node in
  aux trail node

let parent c =
  let c, v = view_cursor c in
  match v with
  | Bud _ -> go_up_to_bud c
  | _ -> Error (Move "parent: cursor must be at a bud")

let unify_extenders prev_trail node context i = match node with
  | Disk (_, Is_Extender) -> Error (Move "unify_exenders: Disk is not allowed")
  | View (Extender (seg, n, _, _)) ->
      begin match prev_trail with
        | Extended (prev_trail', seg', _mr) ->
            Ok (attach prev_trail' (new_extender (Segment.append seg' seg) n) context i)
        | _ -> Ok (attach prev_trail node context i)
      end
  | _ -> Ok (attach prev_trail node context i)

let rec remove_up trail context i = match trail with
  | Top -> Error (Move "cannot remove top") (* XXX *)
  | Budded (prev_trail, _) ->
      Ok (attach prev_trail (new_bud None) context i)
  | Extended (prev_trail, _, _) -> remove_up prev_trail context i
  (* for Left and Right, we may need to squash Extenders in prev_trail *)
  | Left (prev_trail, right, _) ->
      (*
               /               /
              /\       =>      \
         --> *  r               r

         We must load r because r can be an extender!
      *)
      let right = View (Node_storage.view context right) in
      let n = new_extender Segment.(of_sides [Right]) right in
      unify_extenders prev_trail n context i
  | Right (left, prev_trail, _) ->
      (*
               /
              /\
             l  * <--

         We must load l because l can be an extender!
      *)
      let left = View (Node_storage.view context left) in
      let n = new_extender Segment.(of_sides [Left]) left in
      unify_extenders prev_trail n context i

(* Let [c] is a cursor which points an Extender, whose segment is [common_prefix @ remaining_extender].
   [diverge c (common_prefix, remaining_extender, remaining_segment)] diverges a segment of [c] in the middle
   and create a path to [common_prefix @ remaining_segnet].
   It returns the newly created trail.

       /         /
       \         \
       /         /\
       \         \ \
        x         x y
*)
let diverge (Cursor (trail, extender, _context, _i)) (common_prefix, remaining_extender, remaining_segment) =
  match extender with
  | View (Extender (_seg, n, _ir, _hit)) -> (* _seg = common_prefix @ remaining_extender *)
      (* XXX The order is very confusing.  remaining_segment and remaining_extender *)
      begin match Segment.cut remaining_segment, Segment.cut remaining_extender with
        | None, _ -> error_cursor_invariant "diverge: remaining_segment is empty"
        | _, None -> error_cursor_invariant "diverge: remaining_extender is empty"
        | Some (side, seg), Some (side', seg') ->
            (* go down along common_prefix *)
            assert (side <> side');
(*
     /           /
     \           \
     /           /\<----- seg'
    x           x  y
*)
            let trail =
              if Segment.is_empty common_prefix then trail
(*
   /    }
   \    } trail
   o
   /\
   \ \
   /  y
  x
*)
              else _Extended (trail, common_prefix, Modified)
            in
            let n' = new_extender seg' n in
            match side with
            | Segment.Left ->
                if Segment.is_empty seg then
(*
   /    /
   \    \
   /    /\
  x    x  y <-----


*)
                  Ok (_Left (trail, n', Modified))
                else
(*
   /    /
   \    \
   /    /\
   \    \ \
   /    /  y <-------
  x    x
*)
                  Ok (_Extended (_Left (trail, n', Modified), seg, Modified))
            | Segment.Right ->
                if Segment.is_empty seg then
                  Ok (_Right (n', trail, Modified))
                else
                  Ok (_Extended (_Right (n', trail, Modified), seg, Modified))
      end
  | _ -> error_cursor_invariant "diverge: not an Extender"

(* Follow the segment from the cursor. If the segment terminates
   or diverges in the middle of an extender, it returns the common prefix
   information.
*)
type access_result =
  | Empty_bud (* The bud is empty *)
  | Collide of cursor * view (* The segment was blocked by an existing leaf or bud *)
  | Middle_of_extender of cursor * Segment.t * Segment.t * Segment.t (* The segment ends or diverges at the middle of an Extender with the common prefix, the remaining extender, and the rest of segment *)
  | Reached of cursor * view (* just reached to a node *)
  | HashOnly of cursor * Hash.t * Segment.t (* Collided with Hash only node *)

type Error.t +=
  | Access of access_result
  (*  | Cursor_other of string *)

let () = Error.register_printer (function
    | Access a ->
        Some (match a with
            | Empty_bud -> "Nothing beneath this bud"
            | Collide _ -> "Collision before reaching the target"
            | Middle_of_extender (_, _, _, seg) when Segment.is_empty seg ->
                "Finished at the middle of an Extender"
            | Middle_of_extender (_, _, _, _) ->
                "Diverged in the middle of an Extender"
            | Reached (_, Bud _) -> "Reached to a Bud"
            | Reached (_, Leaf _) -> "Reached to a Leaf"

            | Reached (_, Internal _) -> "Reached to an Internal"
            | Reached (_, Extender _) -> "Reached to an Extender"
            | HashOnly (_, _, _) -> "Collided with a Hash only node"
          )
    (*    | Cursor_other s -> Some s *)
    | _ -> None)

let error_access a = Error (Access a)

let access_gen' (Cursor (trail, n, context, i)) segment =
  (* returns the cursor found by following the segment from the given cursor *)
  let rec aux trail n segment j =
    match n with
    | Hash h -> Ok (HashOnly (_Cursor(trail, n, context, i), h, Segment.drop j segment))
    | _ ->
        let v = Node_storage.view context n in
        if Segment.length segment = j then
          let cur = _Cursor (trail, View v, context, i) in
          Ok (Reached (cur, v))
        else
          match v with
          | Leaf _ | Bud _ ->
              let cur = _Cursor (trail, View v, context, i) in
              Ok (Collide (cur, v))
          | Internal (l, r, indexed, hashed) -> begin
              match Segment.get_side segment j with
              | None -> assert false
              | Some Left ->
                  let new_trail = _Left (trail, r, Unmodified (indexed, hashed)) in
                  aux new_trail l segment (j+1)
              | Some Right ->
                  let new_trail = _Right (l, trail, Unmodified (indexed, hashed)) in
                  aux new_trail r segment (j+1)
            end
          | Extender (extender_segment, node_below, indexed, hashed) ->
              let (shared, remaining_extender, remaining_segment) =
                Segment.common_prefix extender_segment (Segment.drop j segment) in
              if Segment.is_empty remaining_extender then
                let new_trail =
                  _Extended (trail, extender_segment, Unmodified (indexed, hashed)) in
                aux new_trail node_below remaining_segment 0
              else
                let cur = _Cursor (trail, View v, context, i) in
                Ok (Middle_of_extender (cur, shared, remaining_extender, remaining_segment))
  in
  aux trail n segment 0

(* [cur] must point to a bud.
   If [segment = []], returns a node attached to the bud.
*)
let access_gen cur segment =
  go_below_bud cur >>? function
  | None -> Ok Empty_bud
  | Some cur -> access_gen' cur segment

let subtree cur seg =
  access_gen cur seg >>? function
  | Reached (cur, Bud _) -> Ok cur
  | res -> error_access res

let get cur seg =
  access_gen cur seg >>? function
  | Reached (c, (Bud _ as v)) -> go_up_to_bud c >>? fun c -> Ok (c, `Bud v)
  | Reached (c, (Leaf _ as v)) -> go_up_to_bud c >>? fun c -> Ok (c, `Leaf v)
  | res -> error_access res

let get_value cur seg =
  access_gen cur seg >>? function
  | Reached (c, Leaf (v, _, _)) ->
      go_up_to_bud c >>? fun c -> Ok (c, v)
  | Reached _ as res -> error_access res (* XXX throwing away the updated cur... *)
  | res -> error_access res

let empty context =
  (* A bud with nothing underneath, i.e. an empty tree or an empty sub-tree. *)
  _Cursor (_Top, new_bud None, context, Info.empty)

let delete cur seg =
  access_gen cur seg >>? function
  | Reached (Cursor (trail, _, context, i), (Bud _ | Leaf _)) ->
      remove_up trail context i
      >>? go_up_to_a_bud
  | res -> error_access res

let delete' cur seg =
  access_gen cur seg >>? function
  | Reached (Cursor (trail, _, context, i), _) ->
      remove_up trail context i
      >>? go_up_to_a_bud
  | res -> error_access res

let alter (Cursor (trail, _, context, i) as cur) segment alteration =
  access_gen cur segment >>? function
  | Empty_bud ->
      alteration None >>? fun n ->
      let n = new_extender segment n in
      let n = new_bud (Some n) in (* This replaces the current empty bud *)
      Ok (attach trail n context i)
  | (Middle_of_extender (_, _, _, seg) as res) when Segment.is_empty seg -> error_access res
  | (Reached (c, _) | Middle_of_extender (c, _, _, _) | HashOnly (c, _, _) as res) ->
      (match res with
       | Reached _ ->
           (* Should we view the node? *)
           let Cursor (trail, n, context, _i) = c in
           let v = Node_storage.view context n in
           Ok (trail, Some v)
       | Middle_of_extender (_c, shared, rest_extender, rest_segment) ->
           diverge c (shared, rest_extender, rest_segment) >|? fun trail -> (trail, None)
       | HashOnly (c, _nh, seg) when Segment.is_empty seg ->
           let Cursor (trail, _, _, _) = c in
           Ok (trail, None (* XXX Pretending there is nothing.  Is it ok? *) )
       | HashOnly _ -> error_access res
       | _ -> assert false) >>? fun (trail, vo) ->
      alteration vo >>? fun n ->
      (* Skip the alteration if identical *)
      let no_mod = match vo, n with
        | Some v, View v' when v == v' -> true
        | Some (Leaf (v, i, h)), View (Leaf (v', i', h')) when v = v' ->
            begin match (i, i'), (h, h') with
              | (Indexed _, _ | Not_Indexed, Not_Indexed),
                (Hashed _, _ | Not_Hashed, Not_Hashed) -> true
              | _ -> false
            end
        | _ -> false
      in
      let c =
        if no_mod then c else attach trail n context i
      in
      (* go_up is required since c may point to a new bud *)
      go_up c >>? go_up_to_a_bud
  | res -> error_access res

let update cur segment value =
  access_gen cur segment >>? function
  | Reached (Cursor (trail, _, context, i), Leaf _) ->
      go_up_to_bud (attach trail (View (_Leaf (value, Not_Indexed, Not_Hashed))) context i)
  | res -> error_access res

type Error.t +=
  | Write of string

let () = Error.register_printer @@ function
  | Write s -> Some ("Write: " ^ s)
  | _ -> None

let upsert cur segment value =
  alter cur segment (fun x ->
      let y = Ok (new_leaf value) in
      match x with
      | None -> y
      | Some (Leaf _) -> y
      | Some _ -> Error (Write "a non Leaf node already presents for this path"))

let insert cur segment value =
  alter cur segment (function
      | None -> Ok (new_leaf value)
      | Some _ -> Error (Write "a node already presents for this path"))

(* XXX If the parent node is Extender, nh postfix must be "" *)
let set_hashonly cur segment nh = alter cur segment (fun _ -> Ok (Hash nh))

let create_subtree cur segment =
  alter cur segment (function
      | None -> Ok (new_bud None)
      | Some _ -> Error (Write "a node already presents for this path"))

let subtree_or_create cur segment =
  (* XXX inefficient.  create_subtree should have an option not to go back to the original position *)
  let cur =
    match create_subtree cur segment with
    | Ok cur -> cur
    | Error _ -> cur
  in
  subtree cur segment

(* XXX bug.  No point using the Cursor. Loaded nodes are forgotten after [traverse] *)
let traverse acc cs f = match cs with
  | [] -> acc, []
  | c::cs ->
      let c, v = view_cursor c in
      match f acc c with
      | `Exit, acc -> acc, []
      | `Up, acc -> acc, cs
      | `Continue, acc ->
          match v with
          | Leaf _ | Bud (None, _, _) -> acc, cs
          | Bud (Some _, _, _) ->
              acc, from_Some (from_Ok (go_below_bud c)) :: cs
          | Internal (_, _, _, _) ->
              let c1 = from_Ok @@ go_side Left c in
              let c2 = from_Ok @@ go_side Right c in
              acc, c1 :: c2 :: cs
          | Extender (_, _, _, _) ->
              acc, from_Ok (go_down_extender c) ::cs

let fold ~init c f =
  let rec aux acc cs = match traverse acc cs f with
    | acc, [] -> acc
    | acc, cs -> aux acc cs
  in
  aux init [c]

let stat (Cursor (_,_,{ stat ; _ }, _)) = stat

let view = view_cursor

(* XXX This function should be deprecated
   because of its semantics complexity *)
let remove_empty_bud c =
  match view c with
  | Cursor (Top, _, _, _), _ -> Ok c
  | c, Bud (None, _, _) ->
      let Cursor (trail, node, context, i) = c in
      let rec find tr n =
        go_up'
          (fun _ -> tr)
          (fun trail node -> match trail with
             | Top -> tr
             | _ ->
                 (let v = Node.view context node in
                  match v with
                  | Leaf _ | Bud (None, _, _) -> assert false
                  | Bud (Some _, _, _) | Extender _ -> find trail (View v)
                  | Internal _ -> tr))
          tr
          n
      in
      let trail = find trail node in
      remove_up trail context i
  | _ -> Ok c

let may_forget c =
  let Cursor (trail, n, context, i) = c in
  (* Bud cannot have Disk as its child
     here we have a quick workaround
  *)
  match trail with
  | Budded _ -> None
  | _ ->
      match Node_type.may_forget n with
      | None -> None
      | Some n -> Some (_Cursor (trail, n, context, i))

(*
let clean_bud c =
  let (Cursor (trail, _, context, i) as c), v = view c in
  match v with
  | Bud (None, _, _) -> Ok c
  | Bud (Some _, _, _) -> Ok (_Cursor (trail, new_bud None, context, i))
  | _ -> Error (Cursor_other "clean_bud: it is not a bud")
*)

let compute_hash (Cursor (trail, node, context, i)) =
  let n, nh = Node_hash.compute context.hash (Node_storage.read_hash context) node in
  _Cursor (trail, n, context, i), nh

let compute_hash' g (Cursor (trail, node, context, i)) =
  let n, nh = Node_hash.compute context.hash g node in
  _Cursor (trail, n, context, i), nh

let forget_info (Cursor (trail, node, context, _)) = _Cursor (trail, node, context, Info.empty)

module Monad = struct
  (** Cursor (zipper) based tree operations, in monadic style *)

  module Base = struct
    type 'a t = cursor -> cursor * ('a, Error.t) Result.t

    let return : 'a -> 'a t = fun a c -> (c, Ok a)

    let bind : 'a t -> ('a -> 'b t) -> 'b t = fun at f c ->
      match at c with
      | (c, Error e) -> (c, Error e)
      | (c, Ok a) -> f a c
  end

  include Monad.Make1(Base)

  let path c = c, Ok (path_of_cursor c)
  let local_segment c = c, Ok (local_seg_of_cursor c)
  let view c = let c, v = view c in c, Ok v
  let index c = c, Ok (index c)

  let go_below_bud c =
    match go_below_bud c with
    | Error e -> c, Error e
    | Ok None -> c, Error (Access Empty_bud)
    | Ok (Some c) -> c, Ok ()

  let wrap_unit f c =
    match f c with
    | Ok c -> c, Ok ()
    | Error e -> c, Error e

  let go_side side = wrap_unit @@ go_side side
  let go_down_extender = wrap_unit go_down_extender
  let go_up = wrap_unit go_up
  let go_top = wrap_unit (fun c -> Ok (go_top c))
  let go_up_to_bud = wrap_unit go_up_to_bud
  let subtree seg = wrap_unit (fun c -> subtree c seg)

  (* XXX should have an original version *)
  let get seg c =
    match get c seg with
    | Ok (c, v) -> c, Ok v
    | Error e -> c, Error e

  let get_value seg c =
    match get_value c seg with
    | Ok (c, v) -> c, Ok v
    | Error e -> c, Error e

  let delete seg = wrap_unit (fun c -> delete c seg)
  let alter seg f = wrap_unit (fun c -> alter c seg f)
  let update seg v = wrap_unit (fun c -> update c seg v)
  let upsert seg v = wrap_unit (fun c -> upsert c seg v)
  let insert seg v = wrap_unit (fun c -> insert c seg v)
  let create_subtree seg = wrap_unit (fun c -> create_subtree c seg)
  let subtree_or_create seg = wrap_unit (fun c -> subtree_or_create c seg)

  let stat c =
    let Cursor (_,_,{ stat ; _ },_) = c in
    c, Ok stat

  let may_forget c =
    match may_forget c with
    | None -> c, Ok ()
    | Some c -> c, Ok ()
end

module Cursor_storage = struct

  let write_top_cursor (Cursor (trail, node, context, info) as c) =
    match trail with
    | Top ->
        let+? (node, i, h) = Node_storage.write_node context node in
        (_Cursor (_Top, node, context, info), i, h)
    | _ ->
        let path = path_of_cursor c in
        failwith (Printf.sprintf "commit: cursor must point to the root: %s"
                    (* LRLLLRRLR... Not quite useful... *)
                    (Path.to_string path))

  let read_fully ~reset_index (Cursor (trail, node, context, i)) =
    _Cursor (trail, Node_storage.read_node_fully ~reset_index context node, context, i)

  module Internal = struct
    let read_fully_for_test (Cursor (trail, node, context, i)) =
      _Cursor (trail, Node_storage.Internal.read_node_fully_for_test context node, context, i)
  end
end

(* debug *)
let deep_stat level c =
  let bud_empty = ref 0 in
  let bud_non_empty = ref 0 in
  let leaf = ref 0 in
  let internal = ref 0 in
  let extender = ref 0 in
  let cntr = ref 0 in
  (* XXX A shared node is visited more than once *)
  fold ~init:() c (fun () c ->
      incr cntr;
      if !cntr mod 1000000 = 0 then begin
        Log.notice "stat: %d steps" !cntr; (* like 8580000 steps *)
      end;
      let _, v = view c in
      begin match v with
        | Bud (None, _, _) -> incr bud_empty
        | Bud (Some _, _, _) -> incr bud_non_empty
        | Leaf (_v, _, _) -> incr leaf
        | Internal (_, _, _, _) -> incr internal
        | Extender (_, _, _, _) -> incr extender
      end;
      `Continue, ());

  let* fd = Lwt_unix.(openfile "stats.csv" [O_CREAT; O_WRONLY; O_APPEND] 0o644) in
  let s = Printf.sprintf "%ld, %d, %d, %d, %d, %d\n" level
      !bud_empty
      !bud_non_empty
      !internal
      !extender
      !leaf
  in
  prerr_endline "stat done.";
  let* w = Lwt_unix.write fd (Bytes.of_string s) 0 (String.length s) in
  assert (w > 0);
  Lwt_unix.close fd