Source file rope.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Rope to store text with tags.

  This module should not be used directly by library user, but rather
  through the {!Textbuffer} module.
*)

module Tag = Texttag.T
module TagSet = Texttag.TSet

[@@@landmark "auto" ]

type char = Uchar.t

(** A range is a start position and a size. Both are in Utf8 characters,
  not in byte. *)
type range = {
    start: int;
    size: int;
  }

let pp_range ppf r = Format.fprintf ppf "{start=%d, size=%d}" r.start r.size
let string_of_range r = Printf.sprintf "{start=%d, size=%d}" r.start r.size

let range ~start ~size = { start ; size }

(** [zero_range] is [range ~start:0 size:0]. Typically used for
 accumulators start value. *)
let zero_range = range ~start:0 ~size:0

type t =
| Leaf of leaf
| Node of node

and parent = Left of node | Right of node
and leaf = {
    mutable parent: parent option
    (** a leaf with no parent means it is not part of the rope any more *) ;
    mutable size: int;
    mutable contents: Buffer.t ;
    mutable tags : (TagSet.t * Tag.t option) array
      (** set of tags, optional lang tag *) ;
    }

and node = {
    mutable parent : parent option ;
    mutable size_l: int; mutable left: t;
    mutable size_r: int; mutable right: t;
  }

let no_tag = (TagSet.empty, None)
let zero_tags = Array.make 0 no_tag

let parent = function
| Leaf l -> l.parent
| Node n -> n.parent

let leaf_offset =
  let rec iter acc = function
  | None -> acc
  | Some (Left p) -> iter acc p.parent
  | Some (Right p) -> iter (p.size_l + acc) p.parent
  in
  fun (l:leaf) ->
    match l.parent with
    | None -> None
    | x -> Some (iter 0 x)

let rope_size = function
| Leaf { size } -> size
| Node { size_l ; size_r } -> size_l + size_r

let check =
  let rec iter = function
  | Leaf l ->
      let s = Utf8.length (Buffer.contents l.contents) in
      if l.size <> s then
        Log.err (fun m -> m "Leaf has size %d but contents of size %d" l.size s);
      if Array.length l.tags <> l.size then
        Log.err (fun m -> m "Leaf has size %d but tag array has size %d"
           l.size (Array.length l.tags))
  | Node n ->
      (match parent n.left with
       | None -> Log.err  (fun m -> m "missing parent for left child")
       | Some (Right _) -> Log.err (fun m -> m "left child has Right parent")
       | Some (Left p) when n != p -> Log.err (fun m -> m "left child has wrong parent")
       | _ -> ()
      );
      (match parent n.right with
       | None -> Log.err (fun m -> m "missing parent for right child")
       | Some (Left _) -> Log.err (fun m -> m "right child has Left parent")
       | Some (Right p) when n != p -> Log.err (fun m -> m "right child has wrong parent")
       | _ -> ()
      );
      let size_l = rope_size n.left in
      let size_r = rope_size n.right in
      if size_l <> n.size_l then
        Log.err (fun m -> m "Node has wrong size_l:%d instead of left child size:%d" n.size_l size_l);
      if size_r <> n.size_r then
        Log.err (fun m -> m "Node has wrong size_r:%d instead of right child size:%d" n.size_r size_r);
      iter n.left ;
      iter n.right
  in
  iter

let pp_leaf ppf { size ; contents } =
  Format.fprintf ppf "{size=%d; contents=%S}"
    size (Buffer.contents contents)

let pp =
  let rec iter ppf margin pos = function
  | Leaf l -> Format.fprintf ppf "%s[%d]%a\n" margin pos pp_leaf l
  | Node n ->
    Format.fprintf ppf "%s[%d]Node {size_l=%d, size_r=%d\n" margin pos n.size_l n.size_r;
    let margin2 = margin^"  " in
    iter ppf margin2 pos n.left ;
    iter ppf margin2 (pos + n.size_l) n.right ;
    Format.fprintf ppf "%s}\n" margin
  in
  fun ppf t -> iter ppf "" 0 t

let iter =
  let rec iter f = function
  | Leaf { contents } -> f contents
  | Node { left ; right } -> iter f left ; iter f right
  in
  iter

let create_leaf ?parent tags size str =
  let contents = Buffer.create size in
  Buffer.add_string contents str ;
  { parent ; size ; contents ; tags }

let set_leaf l ?parent tags size str =
  Buffer.reset l.contents ;
  Buffer.add_string l.contents str ;
  l.size <- size ;
  l.tags <- tags ;
  match parent with
  | Some p -> l.parent <- p
  | None -> ()

let create () =
  (* we must not have a single leaf, but always a node on top *)
  let left = create_leaf zero_tags 0 "" in
  let right = create_leaf zero_tags 0 "" in
  let n = { parent = None;
      size_l = 0; left = Leaf left;
      size_r = 0 ; right = Leaf right;
    }
  in
  left.parent <- Some (Left n);
  right.parent <- Some (Right n);
  Node n

let leaf_at =
  let rec iter at pos = function
  | Leaf l ->
      let offset = at - pos in
      if offset > l.size then
        None
      else
        Some (offset, l)
  | Node n ->
      if at <= pos + n.size_l then
        iter at pos n.left
      else
        iter at (pos+n.size_l) n.right
  in
  fun r at -> iter at 0 r

let rec move_in_rope ~target ~pos = function
| Leaf ({ size } as l) when target >= pos && target <= pos + size ->
    (* special case: for 0-offset_in_leaf in a right leaf, move to
       and of the sibling left branch, i.e. move up to parent and
       go down *)
    (
     match l.parent with
     | None -> (* error *)
         Log.err (fun m -> m "Orphan node");
         (target, target - pos, l)
     | Some (Right p) when target = pos ->
         move_in_rope ~target ~pos:(pos - p.size_l) (Node p)
     | Some _ -> (target, target - pos, l)
    )
| Leaf l ->
    (
     match l.parent with
     | None -> Log.err (fun m -> m "Orphan leaf"); (pos, 0, l)
     | Some p ->
         let pos, p =
           match p with
           | Right p -> (pos - p.size_l, p)
           | Left p -> (pos, p)
         in
         move_in_rope ~target ~pos (Node p)
    )
| Node n when target < pos || target > pos + n.size_l + n.size_r ->
    (
     match n.parent with
     | None when target > pos + n.size_l + n.size_r ->
         (* target offset is out of bounds; move to the end of buffer instead *)
         move_in_rope ~target:(n.size_l + n.size_r) ~pos:n.size_l n.right
     | None ->
         (* orphan node, should not happen. Issue error message
            and move to left-most position from here. *)
         Log.err (fun m -> m "Orphan node");
         move_in_rope ~target:0 ~pos:0 (Node n)
     | Some p ->
         let pos, p =
           match p with
           | Right p -> (pos - p.size_l, p)
           | Left p -> (pos, p)
         in
         move_in_rope ~target ~pos (Node p)
    )
| Node n when target > pos + n.size_l ->
    (* go down right *)
    move_in_rope ~target ~pos:(pos+n.size_l) n.right
| Node n (* go down left *) ->
    move_in_rope ~target ~pos n.left

let rec update_parent_size p diff =
  match p with
  | None -> ()
  | Some (Left n) -> update_parent_left_size n diff
  | Some (Right n) -> update_parent_right_size n diff
and update_parent_left_size n diff =
  n.size_l <- n.size_l + diff;
  update_parent_size n.parent diff
and update_parent_right_size n diff =
  n.size_r <- n.size_r + diff;
  update_parent_size n.parent diff

let cut_leaf l pos =
(*  [%debug "cut_leaf pos=%d %a" pos pp_leaf l);*)
  let str = Buffer.contents l.contents in
  let (str_l, str_removed, str_r) = Utf8.cut str ~pos:pos ~len:0 in
  assert (str_removed = "");
  let size_l = Utf8.length str_l in
  let size_r = Utf8.length str_r in
  assert (size_l + size_r = l.size);
  [%debug "l.size=%d pos=%d size_l=%d, size_r=%d" l.size pos size_l size_r];
  let tags_r = Array.sub l.tags pos size_r  in
  let right = create_leaf tags_r size_r str_r in
  let n = { parent = l.parent ;
      size_l ; left = Leaf l ;
      size_r ; right = Leaf right ;
    }
  in
  let tags_l = Array.sub l.tags 0 size_l in
  set_leaf l ~parent:(Some (Left n)) tags_l size_l str_l ;
  right.parent <- Some (Right n);
  Node n

let max_leaf_size = ref 500

let insert_string =
  let rec iter s ~tags ~size ~at ~pos = function
  | Node ({ left = Leaf l } as n) when at < pos + n.size_l ->
      (* cut leaf in two *)
      n.left <- cut_leaf l (at - pos);
      iter s ~tags ~size ~at ~pos (Node n)
  | Node ({ left = Leaf l } as n) when at = pos + n.size_l ->
      if l.size + size > !max_leaf_size then
        (
         (* add new leaf *)
         let left_leaf = {
             size = l.size ; contents = l.contents ;
             parent = None ; tags = l.tags ;
           }
         in
         let node = { parent = Some (Left n) ;
             size_l = left_leaf.size ;
             left = Leaf left_leaf ;
             size_r = size ;
             right = Leaf l;
           }
         in
         left_leaf.parent <- Some (Left node);
         l.parent <- Some (Right node);
         l.size <- size;
         l.tags <- Array.make size tags ;
         l.contents <- Buffer.create size ;
         Buffer.add_string l.contents s ;
         n.left <- Node node ;
         update_parent_size node.parent (+size)
        )
      else
        (* append to leaf *)
        (
         Buffer.add_string l.contents s;
         l.size <- l.size + size ;
         l.tags <- Array.append l.tags (Array.make size tags) ;
         update_parent_size l.parent (+size);
        )
  | Node ({ right = Leaf l } as n) when at = pos + n.size_l + n.size_r ->
      if l.size + size > !max_leaf_size then
        (
         (* add new leaf *)
         let left_leaf = {
             size = l.size ; contents = l.contents ;
             parent = None ; tags = l.tags ;
           }
         in
         let node = { parent = Some (Right n) ;
             size_l = left_leaf.size ;
             left = Leaf left_leaf ;
             size_r = size ;
             right = Leaf l;
           }
         in
         left_leaf.parent <- Some (Left node);
         l.parent <- Some (Right node);
         l.size <- size;
         l.tags <- Array.make size tags ;
         l.contents <- Buffer.create size ;
         Buffer.add_string l.contents s ;
         n.right <- Node node ;
         update_parent_size node.parent (+size)
        )
      else
        (
         (* append to leaf *)
         Buffer.add_string l.contents s;
         l.size <- l.size + size ;
         l.tags <- Array.append l.tags (Array.make size tags) ;
         update_parent_size l.parent (+size)
        )

  | Node ({ right = Leaf l } as n) when at > pos + n.size_l ->
      (* cut leaf in two *)
      n.right <- cut_leaf l (at - (pos + n.size_l));
      iter s ~tags ~size ~at ~pos (Node n)
  | Node n ->
      if at <= pos + n.size_l then
         iter s ~tags ~size ~at ~pos n.left
      else
         iter s ~tags ~size ~at ~pos:(pos+n.size_l) n.right
  | Leaf l -> assert false
  in
  fun r ?(tags=TagSet.empty) s at ->
    let tags = (tags, None) in
    let rsize = rope_size r in
    if at > rsize then
      invalid_arg (Printf.sprintf "Rope.insert_string (at=%d, rsize=%d)" at rsize)
    else
      let chunks = Utf8.to_chunks !max_leaf_size s in
      List.fold_left
        (fun acc_size (size, str) ->
           [%debug "Rope.insert_string: iter %S (at=%d, size=%d)"
            str (at+acc_size) size];
           iter str ~tags ~size ~at:(at+acc_size) ~pos:0 r;
           acc_size + size)
        0 chunks

let cut_from_leaf ~at ~size l =
  [%debug "cut_from_leaf at:%d size:%d l.size:%d" at size l.size];
  if at+size > l.size then invalid_arg "Boo!";
  assert (at+size <= l.size);
  let (s_l, s_removed, s_r) = Utf8.cut (Buffer.contents l.contents) ~pos:at ~len:size in
  [%debug "s_l=%S, s_removed=%S, s_r=%S" s_l s_removed s_r];
  let t =
    match s_l, s_r with
    | "", "" -> set_leaf l zero_tags 0 ""; Leaf l
    | "", _ ->
        let tags = Array.sub l.tags (at+size) (l.size-(at+size)) in
        set_leaf l tags (l.size - (at+size)) s_r;
        Leaf l
    | _, "" ->
        let tags = Array.sub l.tags 0 at in
        set_leaf l tags at s_l;
        Leaf l
    | _ ,_ ->
        let tags_r = Array.sub l.tags (at+size) (l.size-(at+size)) in
        let right = create_leaf tags_r (l.size - (at+size)) s_r in
        let n = {
            parent = l.parent ;
            size_l = at ; left = Leaf l;
            size_r = right.size ; right = Leaf right;
          }
        in
        let tags_l = Array.sub l.tags 0 at in
        set_leaf l ~parent:(Some (Left n)) tags_l at s_l ;
        right.parent <- Some (Right n) ;
        Node n
  in
  (t, s_removed)

let delete =
  let rec iter removed ~at ~size ~pos r =
    [%debug "Rope.delete iter ~at:%d ~size:%d ~pos:%d" at size pos];
    match r with
    | Node ({ left = Leaf l } as n) when at < pos + n.size_l ->
        [%debug
           "iter Node { left = Leaf { size = %d } } when at < pos + n.size_l(%d)"
             l.size n.size_l];
        let (size_removed, left) =
          let at = at - pos in
          let size = min size (l.size - at) in
          let (t, s_removed) = cut_from_leaf ~at ~size l in
          Buffer.add_string removed s_removed;
          (Utf8.length s_removed, t)
        in
        let size_l = rope_size left in
        n.left <- left ;
        n.size_l <- size_l;
        update_parent_size n.parent (-size_removed);
        let size = size - size_removed in
        if size > 0 then
          iter removed ~at:at ~size ~pos (Node n)

    | Node ({ right = Leaf l } as n) when at >= pos + n.size_l ->
        [%debug
           "iter Node { right = Leaf { size = %d } } when at >= pos + n.size_l(%d)"
             l.size n.size_l];
        let (size_removed, right) =
          let at = at - pos - n.size_l in
          let size = min size (l.size - at) in
          let (t, s_removed) = cut_from_leaf ~at ~size l in
          Buffer.add_string removed s_removed;
          (Utf8.length s_removed, t)
        in
        let size = rope_size right in
        n.right <- right ;
        n.size_r <- size;
        update_parent_size n.parent (-size_removed)
    | Node n ->
        [%debug "Node { size_l=%d; size_r=%d }" n.size_l n.size_r];
        if at < pos + n.size_l then
          (
           let old_size_l = n.size_l in
           let removed_size = min (n.size_l - (at - pos)) size in
           iter removed ~at ~size ~pos n.left;
           let size = size - removed_size in
           if size > 0 then
             iter removed ~at ~size ~pos:(pos+old_size_l-removed_size) n.right
          )
        else
          iter removed ~at ~size ~pos:(pos+n.size_l) n.right

    | Leaf l ->
        [%debug "Leaf { size=%d; str=%S }" l.size (Buffer.contents l.contents)];
        let old_size = l.size in
        let (s_l, s_removed, s_r) =
          let at = at - pos in
          let len = min size l.size in
          Utf8.cut (Buffer.contents l.contents) ~pos:at ~len
        in
        let size_removed = Utf8.length s_removed in
        Buffer.add_string removed s_removed;
        Buffer.reset l.contents;
        let size_l = Utf8.length s_l in
        let size_r = Utf8.length s_r in
        Buffer.add_string l.contents s_l;
        Buffer.add_string l.contents s_r;
        l.size <- size_l + size_r ;
        let tags = Array.make l.size no_tag in
        [%debug "Rope.delete blitting. l.size=%d, old_size=%d, at=%d, size=%d"
           l.size old_size at size];
        Array.blit l.tags 0 tags 0 size_l ;
        Array.blit l.tags (size_l+size_removed) tags size_l size_r ;
        l.tags <- tags ;
        update_parent_size l.parent (l.size - old_size)
  in
  fun r ~start ~size ->
    let removed = Buffer.create size in
    iter removed ~at:start ~size ~pos:0 r;
    Buffer.contents removed

let of_string s =
  let r = create () in
  insert_string r s 0;
  r

let append_string =
  let rec iter ~tags s size = function
  | Leaf { parent = Some (Right n)}
  | Leaf { parent = Some (Left n)} -> iter ~tags s size (Node n)
  | Leaf l ->
      (
       Buffer.add_string l.contents s;
       l.tags <- Array.append l.tags (Array.make size tags) ;
       l.size <- l.size + size;
       update_parent_size l.parent size
      )
  | Node ({ right = Leaf l} as n) ->
      if l.size + size > !max_leaf_size then
        (
         (* add new leaf *)
         let left_leaf = {
             size = l.size ; contents = l.contents ;
             parent = None ; tags = l.tags ;
           }
         in
         let node = { parent = Some (Right n) ;
             size_l = left_leaf.size ;
             left = Leaf left_leaf ;
             size_r = size ;
             right = Leaf l;
           }
         in
         left_leaf.parent <- Some (Left node);
         l.parent <- Some (Right node);
         l.size <- size;
         l.tags <- Array.make size tags ;
         l.contents <- Buffer.create size ;
         Buffer.add_string l.contents s ;
         n.right <- Node node ;
         update_parent_size node.parent (+size)
        )
      else
        (
         (* append to leaf *)
         Buffer.add_string l.contents s;
         l.size <- l.size + size ;
         l.tags <- Array.append l.tags (Array.make size tags) ;
         update_parent_size l.parent (+size)
        )
  | Node n -> iter ~tags s size n.right
  in
  fun r ?(tags=TagSet.empty) s ->
    let tags = (tags, None) in
    let size = Utf8.length s in
    iter ~tags s size r

let concat =
  let rec iter r size = function
  | Leaf _ -> assert false
  | Node ({ right = Leaf l } as n) ->
      let nright = {
          parent = Some (Right n);
          left = n.right ; size_l = l.size ;
          right = r ; size_r = size ;
        }
      in
      l.parent <- Some (Left nright);
      (match r with
       | Leaf l -> l.parent <- Some (Right nright)
       | Node nr -> nr.parent <- Some (Right nright)
      );
      n.size_r <- n.size_r + size;
      n.right <- Node nright;
      update_parent_size n.parent (+size)
  | Node n ->
      iter r size n.right
  in
  fun r1 r2 ->
    let size = rope_size r2 in
    iter r2 size r1

let insert_at_leaf leaf ?tags s at =
  let (p, at) =
    match leaf.parent with
    | None -> assert false
    | Some (Left p) -> (p, at)
    | Some (Right p) -> (p, p.size_l + at)
  in
  insert_string (Node p) s ?tags at

let to_buffer ?b r =
  let b = match b with
  | None -> Buffer.create (rope_size r)
  | Some b -> b
  in
  iter (Buffer.add_buffer b) r;
  b

let to_string r = Buffer.contents (to_buffer r)

let sub_to_buffer =
  let rec iter b ~start ~size ~pos = function
  | Leaf l ->
      (match G.seg_inter start size pos l.size with
       | None -> ()
       | Some (p, len) ->
           let p = p - pos in
           (*prerr_endline (Printf.sprintf "Rope.sub_to_buffer: p=%d len=%d" p len);*)
           Buffer.add_string b
             (Utf8.sub (Buffer.contents l.contents) ~pos:p ~len)
      )
  | Node n ->
      if start <= pos + n.size_l then
        iter b ~start ~size ~pos n.left;
      if start + size >= pos + n.size_l then
        iter b ~start ~size ~pos:(pos+n.size_l) n.right
  in
  fun b ~start ~size r ->
    (*prerr_endline (Printf.sprintf  "sub_to_buffer: start=%d size=%d" start size);*)
    iter b ~start ~size ~pos:0 r

let sub_to_string ?b ~start ~size r =
  let b = Buffer.create size in
  sub_to_buffer b ~start ~size r;
  Buffer.contents b

let rec go_down = function
| Node n -> go_down n.left
| Leaf l -> l

let rec next_leaf = function
| Leaf { parent = Some (Left p) } -> Some (go_down p.right)
| Leaf { parent = Some (Right p) } -> next_leaf (Node p)
| Node { parent = Some (Left p) } -> Some (go_down p.right)
| Node { parent = Some (Right p) } -> next_leaf (Node p)
| Leaf ({ parent = None } as l) -> Some l
| Node { parent = None } -> None

let sedlexbuf_refill ?(pos=0) ?(offset=0) r =
  let leaf = ref (Some (go_down r)) in
  let pos = ref pos in
  let offset = ref offset in
  let rec iter buf start len n =
    [%debug "sedlexbuf_refill start=%d len=%d n=%d" start len n];
    match !leaf with
    | None -> 0
    | Some l ->
        if n >= len then
          n
        else
          (
           let remain = len - n in
           let to_copy = min (l.size - !offset) remain in
           let str = Buffer.contents l.contents in
           Utf8.blit str !offset buf (start + n) to_copy ;
           pos := !pos + to_copy ;
           if to_copy = remain then
             (
              (* done *)
              offset := !offset + to_copy ;
              let ret = n + to_copy in
              [%debug "sedlexbuf_refill: return %d" ret];
              ret
             )
           else
             (
              match next_leaf (Leaf l) with
              | None ->
                  let ret = n + to_copy in
                  leaf := None ;
                  [%debug "sedlexbuf_refill: return %d (end)" ret];
                  ret
              | x ->
                  leaf := x ;
                  offset := 0;
                  iter buf start len (n+to_copy)
             )
          )
  in
  fun buf start len -> iter buf start len 0

let to_sedlexbuf ?pos ?offset r =
  Sedlexing.create (sedlexbuf_refill ?pos ?offset r)

let sub_to_chars =
 let rec iter acc ~start ~size ~pos = function
  | Leaf l ->
      (match G.seg_inter start size pos l.size with
       | None -> acc
       | Some (p, len) ->
           let p = p - pos in
           (*prerr_endline (Printf.sprintf
            "Rope.sub_to_buffer: start=%d, size=%d, pos=%d, l.size=%d, p=%d len=%d, tags:%d"
            start size pos l.size p len (Array.length l.tags));*)
           let (acc_chars, acc_tags) = acc in
           (*let nchars = List.length acc_chars in*)
           let acc_chars = Utf8.rev_chars ~acc:acc_chars (Buffer.contents l.contents) ~pos:p ~len in
           (*let nchars2 = List.length acc_chars in*)
           (*prerr_endline (Printf.sprintf "added chars: %d" (nchars2 - nchars));*)
           let acc_tags =
             if len = 0
             then acc_tags
             else Array.append acc_tags (Array.sub l.tags p len)
           in
           (acc_chars, acc_tags)
      )
  | Node n ->
      let acc =
        if start < pos + n.size_l then
          iter acc ~start ~size ~pos n.left
        else
          acc
      in
      if start + size >= pos + n.size_l then
        iter acc ~start ~size ~pos:(pos+n.size_l) n.right
      else
        acc
  in
  fun ~start ~size r ->
    (*prerr_endline (Printf.sprintf  "sub_to_buffer: start=%d size=%d" start size);*)
    let (chars, tags) = iter ([], zero_tags) ~start ~size ~pos:0 r in
    let chars = List.rev chars in
    (* prerr_endline (Printf.sprintf "%d(%d): %S" start size
       (let b = Buffer.create 31 in
        List.iter (fun c -> Uutf.Buffer.add_utf_8 b c) chars;
        Buffer.contents b));*)

    (*prerr_endline (Printf.sprintf "combine: chars:%d, tags:%d" (List.length chars) (Array.length tags));*)
    List.combine chars (Array.to_list tags)

let get r start =
  match sub_to_chars ~start ~size:1 r with
  | [c,tags] -> (c,tags)
  | _ -> assert false

let tag_op =
  let rec iter f ~start ~size ~pos = function
  | Leaf l ->
      (match G.seg_inter start size pos l.size with
       | None -> ()
       | Some (p, len) ->
           let p = p - pos in
           (*prerr_endline (Printf.sprintf "Rope.sub_to_buffer: p=%d len=%d" p len);*)
           for i = p to p+len-1 do
             l.tags.(i) <- f (pos+i) l.tags.(i)
           done
      )
  | Node n ->
      if start <= pos + n.size_l then
        iter f ~start ~size ~pos n.left;
      if start + size >= pos + n.size_l then
        iter f ~start ~size ~pos:(pos+n.size_l) n.right
  in
  fun r f ~start ~size ->
    iter f ~start ~size ~pos:0 r

let add_tag r t ~start ~size =
  let f pos (set,langtag) = (TagSet.add set t, langtag) in
  tag_op r f ~start ~size

let remove_tag r t ~start ~size =
  let f pos (set, langtag) = (TagSet.remove set t, langtag) in
  tag_op r f ~start ~size

let remove_lang_tags r =
  let f _pos (set,_) = (set, None) in
  tag_op r f ~start:0 ~size:(rope_size r)

let apply_lang =
  let rec move_to_leaf ~pos ~target leaf =
    (*prerr_endline (Printf.sprintf "move_to_leaf pos=%d target=%d leaf.size=%d"
       pos target leaf.size);*)
    if pos + leaf.size <= target || leaf.size = 0 then
      match next_leaf (Leaf leaf) with
      | None -> None (*Some (0, 0, leaf)*)
      | Some l -> move_to_leaf ~pos:(pos+leaf.size) ~target l
    else
      Some (pos, target - pos, leaf)
  in
  let rec on_token acc_changes ~change_start ~change_size
    ~offset ~offset_in_leaf leaf tag ~size =
      (*prerr_endline (Printf.sprintf "on_token offset=%d, offset_in_leaf=%d size=%d"
         offset offset_in_leaf size);*)
    if size <= 0 then
      (acc_changes, change_start, change_size, offset, offset_in_leaf, leaf)
    else
      let (set, langtag) =
        try leaf.tags.(offset_in_leaf)
        with
          e ->
            (*Format.(fprintf err_formatter
               "on_token offset=%d, offset_in_leaf=%d, rope=%a\n" offset offset_in_leaf pp (Leaf leaf));
               Format.(pp_print_flush err_formatter ());*)
            raise e
      in
      let changed =
        if Option.equal Tag.equal tag langtag then
          false
        else
          (
           leaf.tags.(offset_in_leaf) <- (set, tag);
           true
          )
      in
      let acc_changes, change_start, change_size =
        if changed then
          (acc_changes, change_start, change_size + 1)
        else
          let acc_changes =
            if change_size > 0 then
              (range ~start:change_start ~size:change_size) :: acc_changes
            else
              acc_changes
          in
          (acc_changes, offset+offset_in_leaf, 0)
      in
      match move_to_leaf ~pos:offset ~target:(offset+offset_in_leaf+1) leaf with
      | None -> (acc_changes, change_start, change_size, offset, offset_in_leaf, leaf)
      | Some (offset, offset_in_leaf, leaf) ->
          on_token acc_changes ~change_start ~change_size
            ~offset ~offset_in_leaf leaf tag ~size:(size-1)
  in
  let f (acc_changes, change_start, change_size, offset, offset_in_leaf, leaf) token =
    let (tag, size) = Texttag.Lang.tag_of_token token in
    [%debug "apply_lang: offset=%d, size=%d, token=%s"
       offset size (Higlo.Lang.string_of_token token)];
    on_token acc_changes ~change_start ~change_size
      ~offset ~offset_in_leaf leaf tag ~size
  in
  fun t lang ->
    if rope_size t <= 0 then
      []
    else
      (
       let lb = to_sedlexbuf t in
       let (changes, change_start, change_size, _, _, _) =
         match move_to_leaf ~pos:0 ~target:0 (go_down t) with
         | None -> (* empty rope *)
             assert false
         | Some (offset, offset_in_leaf, leaf) ->
             let tokens =
               try Higlo.Lang.parse_lexbuf ~lang lb
               with e -> Log.warn (fun m -> m "%s" (Printexc.to_string e)); []
             in
             List.fold_left f ([], 0, 0, offset, offset_in_leaf, leaf) tokens
       in
       let changes =
         if change_size > 0 then
           (range ~start:change_start ~size:change_size) :: changes
         else
           changes
       in
       List.rev changes
      )