Source file textbuffer.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                                          *)
(*                                                                               *)
(*********************************************************************************)

open Tsdl

[@@@landmark "auto"]


include (val Log.create_src "stk.textbuffer")

let default_word_char_re = Pcre.(regexp ~iflags:(cflags [`UTF8]) "(*UCP)\\w")

type line_offset = {
    line: int ;
    bol: int ;
    offset: int ;
}

let line_offset ~line ~bol ~offset = { line ; bol; offset }
let pp_line_offset ppf lo =
  Format.fprintf ppf "{line=%d, bol=%d, offset=%d}" lo.line lo.bol lo.offset

let compare_line_offset lo1 lo2 =
  match Stdlib.compare lo1.line lo2.line with
  | 0 -> Stdlib.compare lo1.offset lo2.offset
  | n -> n

let order_line_offsets lo1 lo2 =
  if compare_line_offset lo1 lo2 <= 0
  then (lo1, lo2)
  else (lo2, lo1)

type line_range = {
    lstart : line_offset;
    lstop : line_offset;
  }

let line_range ~start ~stop = { lstart = start ; lstop = stop }
let pp_line_range ppf r =
  Format.fprintf ppf "{start=%a, stop=%a}"
    pp_line_offset r.lstart pp_line_offset r.lstop

let range_of_line_range lr =
  let lstart = lr.lstart in
  let start = lstart.bol + lstart.offset in
  let lstop = lr.lstop in
  let size = (lstop.bol + lstop.offset) - start in
  Rope.range ~start ~size

module Cursor =
  struct
    type gravity = [`Left | `Right]
    let pp_gravity ppf = function
    | `Left -> Format.pp_print_string ppf "L"
    | `Right -> Format.pp_print_string ppf "R"

    type t = {
        mutable offset : int;
        mutable leaf : Rope.leaf;
        mutable offset_in_leaf : int;
        gravity : gravity ;
      } (** A cursor should never point to offset_in_leaf 0 of a right
         branch of a rope node; Rope.move_in_rope should make sure of this. *)

    let create ~gravity ~offset ~leaf ~offset_in_leaf =
      { offset ; leaf ; offset_in_leaf ; gravity }

    let copy_position ~src ~dst =
      dst.offset <- src.offset ;
      dst.offset_in_leaf <- src.offset_in_leaf ;
      dst.leaf <- src.leaf

    let offset c = c.offset

    let pp ppf c =
      Format.fprintf ppf "{offset=%d, leaf=%a, offset_in_leaf=%d, g=%a}"
        c.offset Rope.pp_leaf c.leaf c.offset_in_leaf
        pp_gravity c.gravity

    module Id = Misc.Id()
    module Map = Map.Make(Id)
    module Set = Set.Make(Id)

    let pp_map ppf map =
      Map.iter (fun id c ->
         Format.fprintf ppf "[%a]%a\n" Id.pp id pp c)
        map
  end

module Cursor_map = Cursor.Map
type cursor_gravity = Cursor.gravity
type cursor = Cursor.Id.t
let compare_cursor = Cursor.Id.compare
let equal_cursor = Cursor.Id.equal
let pp_cursor_id = Cursor.Id.pp

module Region =
  struct
    type t = { rstart: Cursor.t; rstop: Cursor.t}
    let create rstart rstop = { rstart ; rstop }
    let pp ppf r = Format.fprintf ppf
      "{start=%a; stop=%a}" Cursor.pp r.rstart Cursor.pp r.rstop
    module Id = Misc.Id()
    module Map = Map.Make(Id)
    let pp_map ppf map =
      Map.iter (fun id c ->
         Format.fprintf ppf "[%a]%a\n" Id.pp id pp c)
        map
  end

type region = Region.Id.t

type change =
| Del of line_range * string
| Ins of line_range * string
| Group of change list

let rec pp_change ppf = function
| Del (range, str) -> Format.fprintf ppf "Del%a(%S)" pp_line_range range str
| Ins (range, str) -> Format.fprintf ppf "Ins%a(%S)" pp_line_range range str
| Group l ->
    Format.fprintf ppf "Group[";
    let len = List.length l in
    List.iteri (fun i c ->
       Format.fprintf ppf "%a%s" pp_change c (if i = len - 1 then "" else "; "))
       l;
    Format.fprintf ppf "]"

type _ Events.ev +=
| Delete_range : (line_range * string -> unit) Events.ev
| Insert_text : (line_range * string -> unit) Events.ev
| Cursor_moved : (cursor * line_offset -> unit) Events.ev
| Modified_changed : (bool -> unit) Events.ev
| Source_language_changed : (string option -> unit) Events.ev

type widget_intf = {
    widget : Widget.widget ;
    on_change : change -> unit ;
    on_cursor_change : cursor -> prev:line_offset -> now:line_offset -> unit ;
    on_tag_change : line_range list -> unit ;
    mutable wcursors : Cursor.Set.t ;
  }

type t = {
    o : Object.o ;
    rope: Rope.t ;
    mutable modified : bool ;
    mutable cursors : Cursor.t Cursor.Map.t ;
    mutable regions : Region.t Region.Map.t ;
    mutable lines : Rope.range array ; (** a line range includes the final '\n' if present *)
    mutable max_undo_levels : int ;
    mutable current_action : (int * change list) option ;
    mutable history : (bool * change) list * (bool * change) list ; (** left list for undo, right list for redo *)
    mutable widgets : widget_intf Oid.Map.t ;
    mutable last_used_cursor : Cursor.Id.t option ;
    mutable source_language : string option ;
    mutable word_char_re : Pcre.regexp ;
    mutable map_in : (Uchar.t -> Uchar.t) option ;
    mutable map_out : (Uchar.t -> Uchar.t) option ;
  }

let obj t = t.o
let lines t = t.lines
let line_count t = Array.length t.lines
let size t = Rope.rope_size t.rope
let rope t = t.rope
let max_undo_levels t = t.max_undo_levels
let last_used_cursor t = t.last_used_cursor

let pp_cursor b ppf id =
  match Cursor.Map.find_opt id b.cursors with
  | None -> Format.fprintf ppf "no cursor %a" Cursor.Id.pp id
  | Some c -> Format.fprintf ppf "%a %a" Cursor.Id.pp id Cursor.pp c

let cut_undo_history t =
  let n = t.max_undo_levels in
  let (undo, redo) = t.history in
  if List.length undo > n then
    let rec iter acc i = function
    | [] -> acc
    | h :: q when i >= n -> acc
    | h :: q -> iter (h::acc) (i+1) q
    in
    let undo = iter [] 0 undo in
    t.history <- (List.rev undo, redo)
  else
    ()
let set_max_undo_levels t n =
  t.max_undo_levels <- n ;
  cut_undo_history t

let reset_history t = t.history <- [], []

let signal_modified_changed t =
  t.o#trigger_unit_event Modified_changed t.modified

let signal_source_language_changed t =
  t.o#trigger_unit_event Source_language_changed t.source_language

let set_modified_ b t =
  if b <> t.modified then
    (
     t.modified <- b;
     signal_modified_changed t
    )

let modified t = t.modified
let set_modified t b =
  if t.modified = b then
    ()
  else
    (
     (* set in history *)
     let f (_,change) = (true, change) in
     let (undo, redo) = t.history in
     t.history <- (List.map f undo, List.map f redo) ;
     set_modified_ b t
    )

let line_of_offset =
  let rec iter (lines:Rope.range array) len offset left right =
    (*debug (fun m -> m "iter left=%d right=%d" left right) ;*)
    if left >= right then
      right
    else
      (
       let sum = left + right in
       let i = sum / 2 in
       (*debug (fun m -> m "lines.(%d) = %a" i Rope.pp_range lines.(i));*)
       let line = lines.(i) in
       if line.start + line.size <= offset then
         iter lines len offset (i+1) right
       else
         if offset < line.start then
           iter lines len offset left i
         else
           i
      )
  in
  fun t offset ->
    debug (fun m -> m "line_of_offset offset=%d" offset);
    let lines = t.lines in
    let len = Array.length lines in
    assert (len > 0);
    iter lines len offset 0 (len-1)

let line_char_of_offset t offset =
  let i = line_of_offset t offset in
  let line = t.lines.(i) in
  (i, offset - line.start)

let offset_of_line_char t ~line ~char =
  let nblines = Array.length t.lines in
  if line >= nblines then
    Rope.rope_size t.rope
  else
    let l = t.lines.(line) in
    (* line.size includes the \n, but we must not take it into
       account when addressing with (line,char), so we use
       line.size - 1, except if this is the last line *)
    let size = max 0
      (if line = nblines - 1 then l.size else l.size - 1)
    in
    l.start + min size char

let line_offset_of_offset t offset =
  let i = line_of_offset t offset in
  let line = t.lines.(i) in
  line_offset ~line:i ~bol:line.start ~offset:(offset - line.start)

let line_range_of_range t r =
  let start = line_offset_of_offset t r.Rope.start in
  let stop = line_offset_of_offset t (r.start + r.size) in
  line_range ~start ~stop

let line_ranges_of_ranges t ranges =
  let lineranges = List.map (line_range_of_range t) ranges in
  (* sort and merge line ranges *)
  let l = List.sort Stdlib.compare lineranges in
  let rec iter acc current = function
  | [] -> List.rev (current :: acc)
  | h::q ->
      if h.lstart.line <= current.lstop.line(* &&
        h.lstart.offset <= current.lstop.offset*)
      then
        iter acc { current with lstop = h.lstop } q
      else
        iter (current::acc) h q
  in
  match l with
  | [] -> []
  | h :: q ->
    let l = iter [] h q in
    (*prerr_endline (Printf.sprintf
       "DONE (%d ranges => %d line ranges)" (List.length ranges) (List.length l));*)
    l

let cursor_of_offset t ?(gravity=`Right) offset =
  let offset2 = min offset (Rope.rope_size t.rope) in
  if offset2 < offset then
    warn (fun m -> m "Textbuffer.cursor_of_offset: offset %d is too big, using %d"
      offset offset2);
  match Rope.leaf_at t.rope offset2 with
  | Some (offset_in_leaf, leaf) ->
      Cursor.create ~gravity ~offset ~leaf ~offset_in_leaf
  | None -> assert false

let get_cursor t id =
  match Cursor.Map.find_opt id t.cursors with
  | None ->
      err (fun m -> m "Invalid cursor %a" Cursor.Id.pp id);
      None
  | x -> x

let add_cursor_to_widget t = function
| None -> (fun _ -> ())
| Some wid ->
    fun cid ->
      match Oid.Map.find_opt wid t.widgets with
      | None ->
          Log.warn (fun m -> m "Widget %a not registered to buffer" Oid.pp wid)
      | Some w -> w.wcursors <- Cursor.Set.add cid w.wcursors

let create_cursor ?widget ?gravity ?(line=0) ?(char=0) ?offset t =
  let c =
    match offset with
    | Some o -> cursor_of_offset t ?gravity o
    | None ->
        let offset = offset_of_line_char t ~line ~char in
        cursor_of_offset t ?gravity offset
  in
  let id = Cursor.Id.gen() in
  t.cursors <- Cursor.Map.add id c t.cursors;
  add_cursor_to_widget t widget id ;
  id

let set_last_used_cursor t c = t.last_used_cursor <- Some c

let dup_cursor t ?widget ?gravity c =
  let gravity = Option.value ~default:c.Cursor.gravity gravity in
  let id = Cursor.Id.gen() in
  let c = { c with gravity } in
  t.cursors <- Cursor.Map.add id c t.cursors;
  add_cursor_to_widget t widget id ;
  id

let remove_cursor t id =
  t.cursors <- Cursor.Map.remove id t.cursors;
  match t.last_used_cursor with
  | Some i when Cursor.Id.equal id i -> t.last_used_cursor <- None
  | _ -> ()

let create_insert_cursor ?widget t =
  match t.last_used_cursor with
  | None -> create_cursor ?widget ~offset:0 t
  | Some id ->
      match get_cursor t id with
      | None -> create_cursor ?widget ~offset:0 t
      | Some c -> dup_cursor t ?widget ~gravity:`Right c

let dup_cursor t ?widget ?gravity id =
  match get_cursor t id with
  | None -> None
  | Some c -> Some (dup_cursor t ?widget ?gravity c)

let register_widget =
  let f intf t =
    let id = intf.widget#id in
    if Oid.Map.mem id t.widgets then
      (
       Log.warn
         (fun m -> m "Widget %s already registered in textbuffer" intf.widget#me);
       None
      )
    else
      (
       t.widgets <- Oid.Map.add id intf t.widgets;
       (* and return a cursor *)
       Some (create_insert_cursor ~widget:intf.widget#id t)
      )
  in
  fun t ~widget ~on_change ~on_cursor_change ~on_tag_change ->
    let intf = {
        widget ; on_change ; on_cursor_change ;
        on_tag_change ; wcursors = Cursor.Set.empty }
    in
    f intf t

let unregister_widget t w =
  let id = w#id in
  match Oid.Map.find_opt id t.widgets with
  | None ->
      Log.warn (fun m -> m "Widget %s was not registered in textbuffer" w#me)
  | Some w ->
      Cursor.Set.iter (remove_cursor t) w.wcursors ;
      w.wcursors <- Cursor.Set.empty ;
      t.widgets <- Oid.Map.remove id t.widgets

let map_string f str =
  match f with
  | None -> str
  | Some f -> Utf8.map f str

let to_string ?(start=0) ?size t =
  if start < 0 then invalid_arg "Textbuffer.to_string" ;
  let str =
    match start, size with
    | 0, None -> Rope.to_string t.rope
    | _ ->
        let size = match size with
          | None -> Rope.rope_size t.rope - start
          | Some s -> s
        in
        Rope.sub_to_string ~start ~size t.rope
  in
  map_string t.map_out str

let chars ~map_out ?(start=0) ?size t =
  if start < 0 then invalid_arg "Textbuffer.chars" ;
  let size =
    match size with
    | None -> Rope.rope_size t.rope - start
    | Some s -> s
  in
  let l = Rope.sub_to_chars ~start ~size t.rope in
  match t.map_out with
  | None -> l
  | Some _ when not map_out -> l
  | Some f -> List.map (fun (c, tags) -> (f c, tags)) l

let get_line t i =
  let len = Array.length t.lines in
  if i < 0 || i >= len then
    invalid_arg
      (Printf.sprintf "Textbuffer.line_to_string i=%d, len=%d" i len)
  else
    t.lines.(i)

let line_chars ~map_out t i =
  let len = Array.length t.lines in
  let range = get_line t i in
  (* last line has no \n *)
  let size = if i = len - 1 then range.size else range.size - 1 in
  chars ~map_out ~start:range.start ~size t

let line_to_string t i =
  let len = Array.length t.lines in
  let range = get_line t i in
  (* last line has no \n *)
  let size = if i = len - 1 then range.size else range.size - 1 in
  let s = to_string ~start:range.start ~size t in
  debug (fun m -> m "line %d: %S" i s);
  s

let create ?source_language ?word_char_re () =
  let word_char_re =
    match word_char_re with
    | Some re -> re
    | None -> default_word_char_re
  in
  let t =
    { o = new Object.o () ;
      rope = Rope.create () ;
      modified = false ;
      cursors = Cursor.Map.empty ;
      lines = Array.make 1 (Rope.range ~start:0 ~size:0);
      regions = Region.Map.empty ;
      current_action = None ;
      history = [], [] ;
      max_undo_levels = 100 ;
      widgets = Oid.Map.empty ;
      last_used_cursor = None ;
      source_language ;
      word_char_re ;
      map_in = None ;
      map_out = None ;
    }
  in
  t


let set_map_in t f = t.map_in <- f
let set_map_out t f = t.map_out <- f

let connect t ev cb = t.o#connect ev cb
let disconnect t cbid = t.o#disconnect cbid

let pcre_match_char rex str = Pcre.(pmatch ~rex str)

let pp_lines ppf lines =
  Array.iteri
    (fun i r -> Format.fprintf ppf "[%d]%a, " i Rope.pp_range r)
    lines

let pp ppf t =
  Format.fprintf ppf
    "{ rope = %a\n  cursors = %a;\n  lines = %a;\n  regions = %a}"
    Rope.pp t.rope Cursor.pp_map t.cursors pp_lines t.lines
    Region.pp_map t.regions

let check =
  let rec check_lines (lines : Rope.range array) len i start =
    if i >= len then
      ()
    else
      (
       let line = lines.(i) in
       if line.start <> start then
         err (fun m -> m "Line %d: start = %d, instead of expected %d"
            i line.start start);
       if line.size < 0 then
         err (fun m -> m "Line %d: size = %d < 0" i line.size);
       check_lines lines len (i+1) (line.start + line.size)
      )
  in
  let check_cursors rope t =
    let f id (c:Cursor.t) =
      match Rope.leaf_offset c.leaf with
      | None ->
          err (fun m -> m "Cursor %a has leaf ouf of rope" Cursor.pp c)
      | Some leaf_off ->
          let off = c.offset - c.offset_in_leaf in
          if off <> leaf_off then
            err (fun m ->
               let file = Filename.temp_file "ropedump" ".txt" in
               let oc = Stdlib.open_out file in
               let ppf = Format.formatter_of_out_channel oc in
               Rope.pp ppf rope;
               Format.pp_print_flush ppf ();
               close_out oc;
               m "Cursor %a has offset %d but its leaf has offset %d (rope dump in %s)"
                 Cursor.Id.pp id off leaf_off file)
    in
    Cursor.Map.iter f t.cursors
  in
  fun t ->
    Rope.check t.rope;
    check_lines t.lines (Array.length t.lines) 0 0;
    check_cursors t.rope t

let update_cursor t c =
  let at = min (Rope.rope_size t.rope) c.Cursor.offset in
  match Rope.leaf_at t.rope at with
  | None -> assert false
  | Some (offset_in_leaf, leaf) ->
      c.offset <- at ;
      c.offset_in_leaf <- offset_in_leaf;
      c.leaf <- leaf

let cursor_offset t id =
  match get_cursor t id with
  | None -> 0
  | Some c -> Cursor.offset c

let cursor_line_offset t id =
  line_offset_of_offset t (cursor_offset t id)

let create_region ?(start_gravity=`Left) ~start ?(stop_gravity=`Right) ~stop t =
  let start = cursor_of_offset t ~gravity:start_gravity start in
  let stop = cursor_of_offset t ~gravity:stop_gravity stop in
  let id = Region.Id.gen () in
  let r = Region.create start stop in
  t.regions <- Region.Map.add id r t.regions;
  id

let remove_region t id =
  t.regions <- Region.Map.remove id t.regions

let regions_by_offset =
  let pred offset r =
    let comp_start =
      match r.Region.rstart.gravity with
      | `Left -> (>=)
      | `Right -> (>)
    in
    let comp_stop =
      match r.Region.rstop.gravity with
      | `Left -> (<)
      | `Right -> (<=)
    in
    (comp_start offset r.rstart) && (comp_stop offset r.rstop)
  in
  fun t offset ->
    Region.Map.fold
      (fun _ r acc -> if pred offset r then r :: acc else acc)
      t.regions []

let line_ranges_from_string ?(start=0) str =
  let (r,l,last_is_nl) = Uutf.String.fold_utf_8
    (fun ((current:Rope.range),acc,last_is_nl) _pos -> function
       | `Malformed str ->
           warn (fun m -> m "Textbuffer.line_ranges_from_string: malformed char %S" str);
           { current with size = current.size + 1 }, acc, false
       | `Uchar c ->
          let current = { current with size = current.size + 1 } in
           match Uchar.to_int c with
           | 10 (* '\n' *) ->
               let acc = current :: acc in
               { start = current.start + current.size ; size = 0 }, acc, true
           | _ ->
               current, acc, false
    )
      ({ start ; size = 0 }, [], false) str
  in
  let l = if r.size > 0 || last_is_nl then r :: l else l in
  let l = List.rev l in
  debug (fun m -> m "line_ranges_from_string start=%d str=%S" start str);
  List.iter (fun r -> debug (fun m -> m "%a" Rope.pp_range r)) l;
  l

let update_cursor_after_insert t (range : Rope.range) c =
  let comp = match c.Cursor.gravity with
    | `Left -> (>)
    | `Right -> (>=)
  in
  let prev = line_offset_of_offset t c.offset in
  if comp c.offset range.start then
    (
     (*warn (fun m -> m "update_cursor_after_insert range=%a c=%a"
       Rope.pp_range range Cursor.pp c);*)
     c.offset <- c.offset + range.size ;
     if c.offset_in_leaf + range.size <= c.leaf.size then
       (* if cursor can 'stay' in its leaf, update only
          offset and offset_in_leaf *)
       c.offset_in_leaf <- c.offset_in_leaf + range.size
     else
       (* else we get new leaf from new offset *)
       update_cursor t c;
     let now = line_offset_of_offset t c.offset in
     Some (prev, now)
    )
  else
    (
     (** Rope leaf the cursor was pointing to may have
        been splitted; In this case, cursor leaf must be
        updated. This can only happen when
        (range.start - c.coffset <= !Rope.max_leaf_size).
        In this case, we update the cursor but do not report
        change (its position did not change).
        *)
     if range.start - c.offset <= !Rope.max_leaf_size then
       update_cursor t c;
     None
    )

let update_cursors_after_insert t range =
  Cursor.Map.fold
    (fun id c acc ->
       match update_cursor_after_insert t range c with
       | None -> acc
       | Some change -> (id, change) :: acc
    ) t.cursors []

let update_regions_after_delete t range =
  Region.Map.iter
    (fun _ r ->
       (* FIXME: gather and return changes *)
       let _ = update_cursor_after_insert t range r.Region.rstart in
       let _ = update_cursor_after_insert t range r.Region.rstop in
       ()
    )
    t.regions

let update_lines_after_insert t (range:Rope.range) str =
  let nb_old_lines = Array.length t.lines in
  let ranges = line_ranges_from_string ~start:range.start str in
  match ranges with
  | [] -> ()
  | _ ->
      let nb_new_lines = List.length ranges - 1 in
      let nb_lines = nb_old_lines + nb_new_lines in
      debug (fun m -> m "update_lines_after_insert %a %S\nnb_old_lines=%d, nb_new_lines=%d, nb_lines=%d"
         Rope.pp_range range str nb_old_lines nb_new_lines nb_lines);
      debug (fun m -> m "t.lines=");
      debug (fun m -> Array.iter (fun l -> m "%a" Rope.pp_range l) t.lines);

      let lines = Array.make nb_lines Rope.zero_range in
      let start_line = line_of_offset t range.start in

      (* ranges should be copied/modified to these lines at the end:
         [0..start_line-1 : old lines
         [start_line..start_line+nb_new_lines] : merged/inserted lines
         [start_line+nb_new_lines..nb_lines] : old lines with start position updated
         *)

      Array.blit t.lines 0 lines 0 start_line ;
      debug (fun m -> m "lines array blit ok, start_line=%d" start_line);

      let next_start =
        match ranges with
        | [] -> assert false
        | [r] ->
            let line = t.lines.(start_line) in
            let line = { line with size = line.size + r.size } in
            lines.(start_line) <- line ;
            debug (fun m -> m "update_lines_after_insert: one_range %a, lines.(%d) <- %a"
               Rope.pp_range r start_line Rope.pp_range line);
            line.start + line.size
        | _ ->
            let rec iter ~i ~start = function
            | [] -> start
            | (r:Rope.range) :: q ->
                (*debug (fun m -> m "iter i=%d start=%d r=%a" i start Rope.pp_range r);*)
                let r =
                  if i = 0 then
                    ( (* add line to beginning of old line; start of old line is
                        start parameter, since i = 0 *)
                     let size = r.start + r.size - start in
                     Rope.range ~start ~size
                    )
                  else
                    match q with
                    | [] ->
                        (* merge line with end of old line where insertion took place *)
                        let old_r = t.lines.(start_line) in
                        let size = r.size + old_r.size - (range.start - old_r.start) in
                        (*debug (fun m -> m "merging line with end of old line: old_r=%a" Rope.pp_range old_r);*)
                        { start ; size }
                    | _ -> r
                in
                (*debug (fun m -> m "lines.(%d) <- %a" (start_line+i) Rope.pp_range r);*)
                lines.(start_line + i) <- r;
                assert (start=r.start);
                iter ~i:(i+1)  ~start:(r.start + r.size) q
            in
            iter ~i:0 ~start:(t.lines.(start_line).start) ranges
      in
      let rec iter start i =
        let old_p = start_line + 1 + i in
        (*debug (fun m -> m "iter start=%d i=%d old_p=%d" start i old_p);*)
        if old_p >= nb_old_lines then
          ()
        else
          (
           let old_r = t.lines.(old_p) in
           let r = { old_r with start } in
           (*debug (fun m -> m "t.lines.(%d) = %a" old_p Rope.pp_range r);*)
           lines.(old_p + nb_new_lines) <- r;
           iter (start + r.size) (i+1)
          )
      in
      iter next_start 0;
      t.lines <- lines;
      debug (fun m -> m "lines set, result: %a" pp t)

let update_after_insert t range str =
  update_lines_after_insert t range str;
  update_cursors_after_insert t range

let flatten_changes =
  let rec iter acc = function
  | Del (r, str) -> Del (r, str) :: acc
  | Ins (r, str) -> Ins (r, str) :: acc
  | Group l -> List.fold_left iter acc l
  in
  fun c -> List.rev (iter [] c)

let raw_offset_in_editable_region offset t =
  true

let signal_changes_to_widget changes w =
  let f c =
    try w.on_change c
    with e ->
        Log.warn (fun m -> m "When signaling %a to %s: %s\n%s"
           pp_change c w.widget#me
             (Printexc.to_string e)
             (Printexc.get_backtrace ()))
  in
  List.iter f changes

let trigger_change_event t = function
| Del (r,str) -> t.o#trigger_unit_event Delete_range (r, str)
| Ins (r,str) -> t.o#trigger_unit_event Insert_text (r, str)
| Group _ -> ()

let rec map_change_out f = function
| Del (r, str) -> Del (r, Utf8.map f str)
| Ins (r, str) -> Ins (r, Utf8.map f str)
| Group g -> Group (List.map (map_change_out f) g)

let signal_change t changes =
  let changes = flatten_changes changes in
  let changes =
    match t.map_out with
    | None -> changes
    | Some f -> List.map (map_change_out f) changes
  in
  let l = Oid.Map.fold (fun _ w acc -> w::acc) t.widgets [] in
  List.iter (signal_changes_to_widget changes) l;
  List.iter (trigger_change_event t) changes

let signal_changes t changes =
  List.iter (signal_change t) changes

let signal_tag_change_to_widget ranges w =
  try w.on_tag_change ranges
  with e ->
      Log.warn (fun m -> m "When signaling tag changes to %s: %s\n%s"
         w.widget#me
           (Printexc.to_string e)
           (Printexc.get_backtrace ()))

let[@landmark] signal_tag_change t ranges =
  let l = Oid.Map.fold (fun _ w acc -> w::acc) t.widgets [] in
  List.iter (signal_tag_change_to_widget ranges) l

let signal_cursor_changes_to_widget changes w =
  let f (c,(prev,now)) =
    try
      if prev <> now && Cursor.Set.mem c w.wcursors then
        w.on_cursor_change c ~prev ~now
      else
        ()
    with e ->
        Log.warn (fun m ->
           m "When signaling cursor_change ~prev:%a ~now:%a to %s: %s\n%s"
           pp_line_offset prev
           pp_line_offset now
             w.widget#me
             (Printexc.to_string e)
             (Printexc.get_backtrace ()))
  in
  List.iter f changes

let signal_cursor_changes t changes =
  let l = Oid.Map.fold (fun _ w acc -> w::acc) t.widgets [] in
  List.iter (signal_cursor_changes_to_widget changes) l;
  List.iter (fun (c,(_,lo)) -> t.o#trigger_unit_event Cursor_moved (c,lo)) changes

let move_cursor t ?(line=0) ?(char=0) ?offset id =
  match get_cursor t id with
  | None -> None
  | Some c ->
      let prev = line_offset_of_offset t c.offset in
      (
       match offset with
       | Some o -> c.offset <- min o (Rope.rope_size t.rope)
       | None ->
           let offset = offset_of_line_char t ~line ~char in
           c.offset <- offset
      );
      update_cursor t c;
      let now = line_offset_of_offset t c.offset in
      signal_cursor_changes t [id,(prev,now)] ;
      Some (now.bol + now.offset)

let move_cursor_to_cursor t ~src ~dst =
  match get_cursor t src with
  | None -> None
  | Some src ->
      let id_dst = dst in
      match get_cursor t dst with
      | None -> None
      | Some dst ->
          let prev = line_offset_of_offset t dst.offset in
          Cursor.copy_position ~src ~dst;
          let now = line_offset_of_offset t dst.offset in
          signal_cursor_changes t [id_dst,(prev,now)] ;
          Some (now.bol + now.offset)

let move_cursor_to_line_start t id =
  match get_cursor t id with
  | None -> None
  | Some c ->
      let (line, char) = line_char_of_offset t c.Cursor.offset in
      match char with
      | 0 -> None
      | _ -> move_cursor t ~line ~char:0 id

let move_cursor_to_line_end t id =
  match get_cursor t id with
  | None -> None
  | Some c ->
      let line_i = line_of_offset t c.Cursor.offset in
      let nblines = Array.length t.lines in
      let line = t.lines.(line_i) in
      let offset =
        if line_i + 1 >= nblines then
          (* last line, no \n at the end *)
          line.start + line.size
        else
          line.start + line.size - 1
      in
      move_cursor t ~offset id

let line_forward_cursor t id n =
  match get_cursor t id with
  | None -> None
  | Some c ->
      let (line, char) = line_char_of_offset t c.Cursor.offset in
      move_cursor t ~line:(max 0 (line+n)) ~char id

let line_backward_cursor t c n = line_forward_cursor t c (- n)

let forward_cursor t cid n =
  match get_cursor t cid with
  | None -> None
  | Some c ->
      let prev = line_offset_of_offset t c.offset in
      let target = max 0 (c.offset + n) in
      let pos = c.offset - c.offset_in_leaf in
      let rope = Rope.Leaf c.leaf in
      debug (fun m -> m "cursor_forward: move_in_rope ~target:%d ~pos:%d" target pos);
      let (offset, offset_in_leaf, leaf) = Rope.move_in_rope ~target ~pos rope in
      c.leaf <- leaf;
      c.offset <- offset;
      c.offset_in_leaf <- offset_in_leaf ;
      let now = line_offset_of_offset t c.offset in
      signal_cursor_changes t [cid,(prev,now)] ;
      Some (now.bol + now.offset)

let backward_cursor t c n = forward_cursor t c (- n)

let look_for_char_from =
  let chunk_size = 10 in
  let rec iter rope rsize pred start size s i =
    if size = 0 then
      None
    else
      let char = Utf8.sub s ~pos:i ~len:1 in
      if not (pred char) then
        let i = i + 1 in
        if i < size then
          iter rope rsize pred start size s i
        else
          let start = start + size in
          let size = min chunk_size (rsize - start) in
          let s = Rope.sub_to_string ~start ~size rope in
          iter rope rsize pred start size s 0
      else
        Some (start+i)
  in
  fun t pred start ->
    let rope_size = Rope.rope_size t.rope in
    let size = min chunk_size (rope_size - start) in
    let s = Rope.sub_to_string ~start ~size t.rope in
    iter t.rope rope_size pred start size s 0

let forward_cursor_to_word_end t cid =
  match get_cursor t cid with
  | None -> None
  | Some c ->
      let pos0 = c.offset in
      let rope_size = Rope.rope_size t.rope in
      if pos0 >= rope_size then
        Some c.offset
      else
        (* look forward for first word char *)
        let pos =
          match look_for_char_from t
            (fun c -> pcre_match_char t.word_char_re c)
            pos0
          with
          | None -> pos0
          | Some pos ->
              (* if we found a word char, let's look for the first
                 char not being a word char *)
              match look_for_char_from t
                (fun c -> not (pcre_match_char t.word_char_re c))
                  pos
              with
              | None -> (* go to end of rope *) rope_size
              | Some p -> p
        in
        (* then move forward cursor to new pos *)
        forward_cursor t cid (pos-pos0)

let look_back_for_char_from =
  let chunk_size = 10 in
  let rec iter rope rsize pred start size s i =
    if i < 0 then
      None
    else
      let char = Utf8.sub s ~pos:i ~len:1 in
      if not (pred char) then
        let i = i - 1 in
        if i >= 0 then
          iter rope rsize pred start size s i
        else
          let s_start = max 0 (start - chunk_size) in
          let size = start - s_start in
          let s = Rope.sub_to_string ~start:s_start ~size rope in
          iter rope rsize pred s_start size s (size-1)
      else
        Some (start+i)
  in
  fun t pred start ->
    let rope_size = Rope.rope_size t.rope in
    let s_start = max 0 (start - chunk_size) in
    let size = start - s_start in
    if size <= 0 then
      None
    else
      let s = Rope.sub_to_string ~start:s_start ~size t.rope in
      iter t.rope rope_size pred s_start size s (size-1)

let backward_cursor_to_word_start t cid =
  match get_cursor t cid with
  | None -> None
  | Some c ->
      let pos0 = c.offset in
      if pos0 <= 0 then
        Some c.offset
      else
        let pos =
          (* look backward for first word char *)
          match look_back_for_char_from t
            (fun c -> pcre_match_char t.word_char_re c)
              pos0
          with
          | None -> pos0
          | Some pos ->
              (* if we found a word char, let's look for the
                 first char not being a word char *)
              match look_back_for_char_from t
                (fun c -> not (pcre_match_char t.word_char_re c))
                  pos
              with
              | None -> (* go to rope start*) 0
              | Some p -> p + 1
        in
        (* then move forward cursor to new pos (negative forward here) *)
        forward_cursor t cid (pos-pos0)

let[@landmark] apply_lang_ lang t =
  let ranges = Rope.apply_lang t.rope lang in
  List.map (line_range_of_range t) ranges

let[@landmark] apply_lang t lang =
  signal_tag_change t (apply_lang_ lang t)

let can_insert t ?readonly offset =
  match readonly with
  | None -> true
  | Some ro ->
      let rsize = Rope.rope_size t.rope in
      let (tags1, tags2) =
        if offset < 0 || offset > rsize then
          invalid_arg (Printf.sprintf "Textbuffer.raw_can_insert (at=%d, rsize=%d)"
           offset rsize)
        else
          if offset = 0 then
            if rsize = 0 then
              (None, None)
            else
              let (_,(t,_)) = Rope.get t.rope offset in
              (None, Some t)
          else
            let (_,(t1,_)) = Rope.get t.rope (offset-1) in
            if offset >= rsize then
              (Some t1, None)
            else
              let (_,(t2,_)) = Rope.get t.rope offset in
              (Some t1, Some t2)
      in
      not (ro tags1 tags2)

let insert_at_cursor t cursor ?readonly ?tags str =
  match get_cursor t cursor with
  | None -> ()
  | Some c when not (can_insert t ?readonly c.offset) -> ()
  | Some c ->
      let str = map_string t.map_in str in
      let tags = Option.map Texttag.TSet.of_list tags in
      let old_offset = c.offset in
      let lstart = line_offset_of_offset t old_offset in
      debug (fun m -> m
         "Textbuffer.insert_at_cursor: leaf=%a offset=%d, offset_in_leaf=%d, lstart=%a"
           Rope.pp_leaf c.leaf old_offset c.offset_in_leaf pp_line_offset lstart);
      let size = Rope.insert_at_leaf c.leaf ?tags str c.offset_in_leaf in
        debug (fun m -> m "insert_at_cursor: old_offset=%d, size inserted=%d, c.offset=%d"
         old_offset size c.offset);
      let range = Rope.range ~start:old_offset ~size in
      let cursor_changes = update_after_insert t range str in
      let lstop = line_offset_of_offset t (old_offset+size) in
      let lrange = { lstart ; lstop } in
      let cursor_changes =
        match c.gravity with
        | `Left -> cursor_changes
        | `Right -> (cursor, (lstart, lstop)) :: cursor_changes
      in
      let change = Ins (lrange, str) in
      (match t.current_action with
       | None ->
           let (undo, redo) = t.history in
           t.history <- ((t.modified, change) :: undo), [] ;
           cut_undo_history t;
           set_modified_ true t
       | Some (count, l) -> t.current_action <- Some (count, change :: l)
      );
      signal_change t change ;
      signal_cursor_changes t cursor_changes ;
      (
       match t.source_language with
       | None -> ()
       | Some lang -> apply_lang t lang
      )

let insert_ ~from_history ?tags at str t =
  let tags = Option.map Texttag.TSet.of_list tags in
  debug (fun m -> m "Rope.raw_insert ~str:%S ~at: %d" str at);
  let lstart = line_offset_of_offset t at in
  let size = Rope.insert_string t.rope ?tags str at in
  let range = Rope.range ~start:at ~size in
  let cursor_changes = update_after_insert t range str in
  let lstop = line_offset_of_offset t (at+size) in
  let lrange = { lstart ; lstop } in
  let change = Ins (lrange, str) in
  if not from_history then
    (
     match t.current_action with
     | None ->
         let (undo, _) =  t.history in
         t.history <- ((t.modified, change) :: undo, []) ;
         cut_undo_history t;
         set_modified_ true t
     | Some (count, l) ->
         t.current_action <- Some (count, change :: l)
    )
  else
    ();
  (*check t;*)
  (change, cursor_changes)

let insert t ?readonly ?tags at str =
  let str = map_string t.map_in str in
  debug (fun m -> m "Textbuffer.insert at=%d %S" at str);
  if can_insert t ?readonly at then
    (
     let (change, cursor_changes) = insert_ ~from_history:false ?tags at str t in
     signal_change t change ;
     signal_cursor_changes t cursor_changes ;
     match t.source_language with
     | None -> ()
     | Some lang -> apply_lang t lang
    )
  else
    ()

let update_cursor_after_delete t (range:Rope.range) c =
  (*warn (fun m -> m "update_after_cursor_delete range=%a cursor=%a"
    Rope.pp_range range Cursor.pp c);*)
  if c.Cursor.offset <= range.start then
    (
     (*warn (fun m -> m "update_after_cursor_delete: no change");*)
     None
    )
  else
    (
     let prev = line_offset_of_offset t c.offset in
     (* it could be optimized but let's update cursor data
        from root of rope by now *)
     if c.offset >= range.start + range.size then
       c.offset <- c.offset - range.size
     else
       c.offset <- range.start;
     update_cursor t c;
     let now = line_offset_of_offset t c.offset in
     (*warn (fun m -> m "update_after_cursor_delete: now = %a" Cursor.pp c);*)
     Some (prev, now)
    )

let update_cursors_after_delete t range =
  Cursor.Map.fold
    (fun id c acc ->
       match update_cursor_after_delete t range c with
       | None -> acc
       | Some change -> (id, change) :: acc
    ) t.cursors []

let update_regions_after_delete t range =
  Region.Map.iter
    (fun _ r ->
      (* FIXME: gather and return cursor changes *)
       let _ = update_cursor_after_delete t range r.Region.rstart in
       let _ = update_cursor_after_delete t range r.Region.rstop in
       ()
    )
    t.regions

let update_lines_after_delete t (range:Rope.range) str =
  let nb_old_lines = Array.length t.lines in
  match line_ranges_from_string ~start:range.start str with
  | [] -> ()
  | ranges ->
      let nb_del_lines = List.length ranges in
      let nb_lines = nb_old_lines - nb_del_lines + 1 in

      debug (fun m -> m "update_lines_after_delete %a %S\nnb_old_lines=%d, nb_del_lines=%d, nb_lines=%d"
         Rope.pp_range range str nb_old_lines nb_del_lines nb_lines);

      let lines = Array.sub t.lines 0 nb_lines in
      let start_line = line_of_offset t range.start in

      let merged_line =
        let old_r = t.lines.(start_line) in
        match ranges with
        | [] -> assert false
        | [line] -> { old_r with size = old_r.size - line.size }
        | first :: q ->
            let last =
              match List.rev q with [] -> assert false | x :: _ -> x
            in
            let old_last = t.lines.(start_line + nb_del_lines - 1) in
            let last_remaining = old_last.size - last.size in
            { old_r with size = old_r.size - first.size + last_remaining }
      in
      debug (fun m -> m "merged_line at %d: %a" start_line Rope.pp_range merged_line);
      lines.(start_line) <- merged_line ;
      let rec iter ~i ~start =
        debug (fun m -> m "iter i=%d start=%d" i start);
        if i >= nb_lines then
          ()
        else
          (
           let old_line = t.lines.(i + nb_del_lines - 1) in
           lines.(i) <- { old_line with start };
           iter ~i:(i+1) ~start:(start+old_line.size)
          )
      in
      iter ~i:(start_line+1) ~start:(merged_line.start+merged_line.size);
      debug (fun m -> m "lines set in buffer:");
      Array.iter (fun l -> debug (fun m -> m "%a" Rope.pp_range l)) lines;
      t.lines <- lines;
      debug (fun m -> m "lines set, result: %a" pp t)

let update_after_delete t range str =
  update_lines_after_delete t range str;
  update_cursors_after_delete t range

let merge_cursor_changes =
  let module M = Cursor.Map in
  let add map (cid, (prev, now)) =
    match M.find_opt cid map with
    | None -> M.add cid (prev, now) map
    | Some (prev,_) -> M.add cid (prev, now) map
  in
  fun changes ->
    let m = List.fold_left add M.empty changes in
    let l = M.bindings m in
    (*let pp ppf l =
      List.iter
        (fun (cid, (prev,now)) ->
           Format.fprintf ppf "(%a: %a -> %a) " Cursor.Id.pp cid
             pp_line_offset prev pp_line_offset now) l
    in
    warn (fun m -> m "merge_cursor_changes: %a@.=> %a" pp changes pp l);*)
    l

let delete_range_ (start,size) t =
  let lstart = line_offset_of_offset t start in
  let lstop = line_offset_of_offset t (start+size) in
  let str = Rope.delete t.rope ~start ~size in
  let lrange = { lstart ; lstop } in
  let range =
    let size = (lstop.bol + lstop.offset) - (lstart.bol + lstart.offset) in
    Rope.range ~start ~size
  in
  let cursor_changes = update_after_delete t range str in
  let change = Del (lrange, str) in
  (change, cursor_changes)

let deletable_ranges readonly start chars =
  let rec iter acc start size = function
  | [] ->
      if size > 0 then
        List.rev ((start, size) :: acc)
      else
        List.rev acc
  | (c,(tags,_)) :: q ->
      let ro = readonly tags in
      debug (fun m -> m "character %S is read-only: %b"
        (Utf8.string_of_uchar c) ro);
      if ro then
        if size > 0 then
          iter ((start,size)::acc) (start+size+1) 0 q
        else
          iter acc (start+1) 0 q
      else
        iter acc start (size+1) q
  in
  debug (fun m -> m "Textview.deletable_ranges start=%d len(char)s=%d"
    start (List.length chars));
  let ranges = iter [] start 0 chars in
  debug (fun m ->
    List.iter
      (fun (start, size) -> m "deletable range: start=%d, size=%d" start size)
      ranges);
  ranges

let delete_ ?readonly ~from_history ~start ~size t =
  debug (fun m -> m "Rope.delete_ ~start:%d ~size: %d" start size);
  let ranges =
    match readonly with
    | None -> [start, size]
    | Some ro ->
        let chars = Rope.sub_to_chars ~start ~size t.rope in
        deletable_ranges ro start chars
  in
  let (changes, cursor_changes, _) =
    (* do not forget that when removing a range, we must translate
       the start position of the next one by the deleted size. We
       use the offset accumulator to do so. *)
    List.fold_left
      (fun (acc_ch, acc_ch_cur, offset) (start, size) ->
         let start = start - offset in
         let (ch, ch_cur) = delete_range_ (start, size) t in
         (ch :: acc_ch, ch_cur :: acc_ch_cur, offset+size)
      )
      ([], [], 0) ranges
  in
  let cursor_changes = merge_cursor_changes
    (List.flatten (List.rev cursor_changes))
  in
  let change =
    match List.rev changes with
    | [x] -> x
    | l -> Group l
  in
  if not from_history then
    (
    match t.current_action with
     | None ->
         let (undo, _) =  t.history in
         t.history <- ((t.modified, change) :: undo, []);
         cut_undo_history t ;
         set_modified_ true t
     | Some (count, l) ->
         t.current_action <- Some (count, change :: l)
    )
  else
    ();
  (*check t;*)
  (change, cursor_changes)

let set_text t str =
  let str = map_string t.map_in str in
  let size = size t in
  let (del_change, del_cursor_changes) = delete_ ~from_history:true ~start:0 ~size t in
  let (ins_change, _) = insert_ ~from_history:true 0 str t in
  let change = Group [ del_change ; ins_change ] in
  (match t.current_action with
   | None ->
       let undo = (t.modified, change) :: (fst t.history) in
       t.history <- (undo, []) ;
       cut_undo_history t ;
       set_modified_ true t
   | Some (count, l) ->
       t.current_action <- Some (count, change :: l)
  );
  signal_change t change ;
  signal_cursor_changes t del_cursor_changes ;
  match t.source_language with
  | None -> ()
  | Some lang -> apply_lang t lang

let delete ?readonly ?(start=0) ?size t =
  let size = match size with None -> Rope.rope_size t.rope | Some s -> s in
  let (change, cursor_changes) =
    delete_ ~from_history:false ?readonly ~start ~size t
  in
  signal_change t change ;
  signal_cursor_changes t cursor_changes ;
  let () =
    match t.source_language with
    | None -> ()
    | Some lang -> apply_lang t lang
  in
  let str =
    match change with
    | Del (_, str) -> str
    | Group l ->
        let b = Buffer.create 256 in
        List.iter
          (function
           | Del (_,str) -> Buffer.add_string b str
           | _ -> assert false)
          l;
        Buffer.contents b
    | _ -> assert false
  in
  map_string t.map_out str

let add_tag t tag ?(start=0) ?(size=size t) () =
  Rope.add_tag t.rope tag ~start ~size ;
  let range = Rope.range ~start ~size in
  let line_range = line_range_of_range t range in
  signal_tag_change t [line_range]

let remove_tag t tag ?(start=0) ?(size=size t) () =
  Rope.remove_tag t.rope tag ~start ~size ;
  let range = Rope.range ~start ~size in
  let line_range = line_range_of_range t range in
  signal_tag_change t [line_range]

let source_language t = t.source_language
let[@landmark] set_source_language t l =
  (* make sure the language is known *)
  match Option.map Higlo.Lang.get_lexer l with
  | exception e ->
      warn
        (fun m -> m "Cannot set source language: %s"
           (Printexc.to_string e))
  | _ ->
      if t.source_language <> l then
        (
         t.source_language <- l;
         let ranges =
           match l with
           | None ->
               Rope.remove_lang_tags t.rope ;
               [line_range_of_range t
                 (Rope.range ~start:0 ~size:(Rope.rope_size t.rope))]
           | Some lang -> apply_lang_ lang t
         in
         signal_tag_change t ranges;
         signal_source_language_changed t
        )

let word_char_re t = t.word_char_re
let set_word_char_re t re = t.word_char_re <- re
let set_word_char_re_string t str =
  let re = Pcre.(regexp ~iflags:(cflags [`UTF8]) str) in
  t.word_char_re <- re

let begin_action t =
  match t.current_action with
  | None -> t.current_action <- Some (1, [])
  | Some (count, l) -> t.current_action <- Some (count + 1, l)

let end_action t =
  match t.current_action with
  | None -> warn (fun m -> m "Textbuffer.end_action: %s has no current action" t.o#me)
  | Some (count, l) ->
      let count = count - 1 in
      if count <= 0 then
        (
         let undo, redo = t.history in
         t.history <- ((t.modified, Group l) :: undo, []);
         set_modified_ true t ;
         t.current_action <- None
        )
      else
        t.current_action <- Some (count, l)

let rec rev_change = function
| Group l -> Group (List.rev_map rev_change l)
| x -> x

let undo =
  let rec undo_change t (acc, acc_cursors) = function
  | Ins (lrange, str) ->
      let range = range_of_line_range lrange in
      let (change, cursor_changes) = delete_ ~from_history:true ~start:range.start ~size:range.size t in
      (change :: acc, cursor_changes :: acc_cursors)
  | Del (lrange, str) ->
      let range = range_of_line_range lrange in
      let (change, cursor_changes) = insert_ ~from_history:true range.start str t in
      (change :: acc, cursor_changes :: acc_cursors)
  | Group l ->
     List.fold_left (undo_change t) (acc, acc_cursors) l
  in
  let f t =
    try
      match t.history with
      | [], _ -> ([], [])
      | (modified,action)::q, redo ->
          debug (fun m -> m "undo %a" pp_change action);
          let (changes, cursor_changes) = undo_change t ([], []) action in
          t.history <- q, ((t.modified, rev_change action)::redo);
          set_modified_ modified t;
          let cursor_changes = List.flatten cursor_changes in
          (List.rev changes, List.rev cursor_changes)
    with
      e ->
        Log.err (fun m -> m "Undo: %s\n%s"
           (Printexc.to_string e) (Printexc.get_backtrace()));
        ([], [])
  in
  fun t ->
    let (changes, cursor_changes) = f t in
    signal_changes t changes ;
    signal_cursor_changes t cursor_changes ;
    match t.source_language with
    | None -> ()
    | Some lang -> apply_lang t lang

let redo =
  let rec redo_change t (acc, cursors) = function
  | Ins (lrange, str) ->
      let range = range_of_line_range lrange in
      let (change, cursor_changes) = insert_ ~from_history:true range.start str t in
      (change :: acc, cursor_changes :: cursors)
  | Del (lrange, str) ->
      let range = range_of_line_range lrange in
      let (change, cursors_changes) =
        delete_ ~from_history:true ~start:range.start ~size:range.size t
      in
      (change:: acc, cursors_changes :: cursors)
  | Group l -> List.fold_left (redo_change t) (acc, cursors) l
  in
  let f t =
    try
      match t.history with
      | _, [] -> ([], [])
      | undo, (modified,action)::q ->
        debug (fun m -> m "redo %a" pp_change action);
          let (changes, cursors_changes) = redo_change t ([], []) action in
          t.history <- (t.modified, rev_change action)::undo, q;
          set_modified_ modified t;
          let cursors_changes = List.flatten cursors_changes in
          (List.rev changes, List.rev cursors_changes)
    with
      e ->
        Log.err (fun m -> m "Redo: %s\n%s"
           (Printexc.to_string e) (Printexc.get_backtrace()));
        ([], [])
  in
  fun t ->
    let (changes, cursor_changes) = f t in
    signal_changes t changes ;
    signal_cursor_changes t cursor_changes ;
    match t.source_language with
    | None -> ()
    | Some lang -> apply_lang t lang