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

(** Textview widget.

Widget to display {{!Textbuffer.type-t}text buffers}.

Additional information can be displayed in a gutter on the left: for
line numbers and line markers.
 *)

open Tsdl
open Tsdl_ttf
open Misc

module B = Textbuffer

[@@@landmark "auto"]

(** {2 Logging}

This module has its own {{!Logs.Src.t}[Logs] source} ["stk.textview"]. See {!Log}.*)

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

(** {2 Properties} *)

(** Property ["show_cursors"] to indicate whether cursors should be rendered.
  Default is [true]. Inherited. *)
let show_cursors = Props.(bool_prop
   ~after:[Render] ~default:true "show_cursors")
let css_show_cursors = Theme.bool_prop show_cursors

(** Wrap mode for lines longer than available width:
  {ul
   {- [Wrap_none]: do not wrap lines.}
   {- [Wrap_char]: wrap lines on any char.}
  }
*)
type wrap_mode = Wrap_none | Wrap_char
let wrap_modes = [Wrap_none ; Wrap_char]

let string_of_wrap_mode = function
| Wrap_none -> "none"
| Wrap_char -> "char"

let wrap_mode_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_wrap_mode wrap_modes

(** {!Ocf.wrapper} for {!type-wrap_mode}.*)
let wrap_mode_wrapper =
  let to_json ?with_doc m = `String (string_of_wrap_mode m) in
  let from_json ?def = function
  | `String s ->
      (match wrap_mode_of_string s with
       | None ->
           Log.warn (fun m -> m "invalid wrap_mode %S; defaulting to Wrap_none" s);
           Wrap_none
       | Some x -> x
      )
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

(**/**)
module TWrap_mode = struct
    type t = wrap_mode
    let compare = Stdlib.compare
    let wrapper = Some wrap_mode_wrapper
    let transition = None
  end
module PWrap_mode = Props.Add_prop_type(TWrap_mode)
(**/**)

(** Property ["wrap_mode"]. Default is [Wrap_none]. Not inherited. *)
let wrap_mode : wrap_mode Props.prop = PWrap_mode.mk_prop
  ~after:[Resize] ~default:Wrap_none
  ~inherited:false "wrap_mode"

let css_wrap_mode_prop = Theme.keyword_prop
  string_of_wrap_mode wrap_mode_of_string Wrap_none

let css_wrap_mode = css_wrap_mode_prop wrap_mode

(** Property ["wrap_char_codepoint"] to specify which character to
  display to indicate a line wrap. Default is [45] ('[-]'). Inherited. *)
let wrap_char_codepoint = Props.int_prop
  ~after:[Render]
  ~default:45 (* 8617 *)
  ~inherited:true "wrap_char_codepoint"
let css_wrap_char_codepoint = Theme.int_prop wrap_char_codepoint

(** Property ["show_line_numbers"] to specify whether line numbers
  must be display in the gutter. Default is [false]. Inherited. *)
let show_line_numbers = Props.bool_prop
  ~after:[Resize]
  ~default:false ~inherited:true "show_line_numbers"
let css_show_line_numbers = Theme.bool_prop show_line_numbers

(** Property ["show_line_markers"] to specify whether line markers
  must be display in the gutter. Default is [false]. Inherited. *)
let show_line_markers = Props.bool_prop
  ~after:[Resize]
  ~default:false ~inherited:true "show_line_markers"
let css_show_line_markers = Theme.bool_prop show_line_markers

(** Property ["gutter_props"] to specify gutter properties, typically
  background and foreground colors. Inherited. *)
let gutter_props : Props.props Props.prop =
  Props.props_prop ~default:(Props.create()) ~after:[Resize] "gutter_props"

(** Property ["highlight_current_line"] to specify whether current
  line (the line with the insert cursor) should be highlighted.
  Default is false. Inherited. *)
let highlight_current_line = Props.bool_prop
  ~after:[Render]
  ~default:false ~inherited:true "highlight_current_line"
let css_highlight_current_line = Theme.bool_prop highlight_current_line

(**/**)

let lwt_array_iteri =
  let rec iter t len f i =
    if i >= len then
      Lwt.return_unit
    else
      let%lwt () = f i t.(i) in
      iter t len f (i+1)
  in
  fun f t -> iter t (Array.length t) f 0

let lwt_array_mapi =
  let rec iter src len f dst i =
    if i >= len then
      Lwt.return_unit
    else
      let%lwt res = f i src.(i) in
      dst.(i) <- res;
      iter src len f dst (i+1)
  in
  fun f t ->
    let len = Array.length t in

    if len <= 0 then
      Lwt.return [| |]
    else
      let%lwt i0 = f 0 t.(0) in
      let dst = Array.make len i0 in
      let%lwt () = iter t len f dst 1 in
      Lwt.return dst

type char = {
    mutable w : int;
    mutable h : int ;
    glyph : int ;
    font_ascent: int;
    font_descent: int;
    font : Font.font ;
    props : Props.t ;
    mutable texture : Sdl.texture option ;
  }

(* display line, i.e. a line when there is no wrap, or a part
  of a line in case of wrapping enabled. *)
type dline = {
  mutable y : int ;
  mutable h : int ;
  mutable baseline : int ;
  mutable w : int ;
  mutable range : Rope.range ;
  mutable texture : Sdl.texture option ;
}
type line = {
  mutable chars : char Array.t ;
  mutable dlines : dline array ;
}

let free_dline_texture d =
  match d.texture with
  | None -> ()
  | Some t -> d.texture <- None

let line_height line = Array.fold_left
  (fun acc l -> acc + l.h) 0 line.dlines

let line_width line = Array.fold_left
  (fun acc l -> max acc l.w) 0 line.dlines

let line_total_width line = Array.fold_left
  (fun acc l -> acc + l.w) 0 line.dlines

let line_y line = match line.dlines with
  | [| |] -> Log.err (fun m -> m "Empty dlines!"); 0
  | dlines -> dlines.(0).y

let update_line_y =
  let iter (oldy, y) dline =
    dline.y <- y;
    (oldy + dline.h, y + dline.h)
  in
  fun line y ->
    let oldy = line.dlines.(0).y in
    let (oldy, y) = Array.fold_left iter (oldy, y) line.dlines in
    (y, oldy <> y)

let dline_of_char =
  let rec iter dlines len ichar idline i =
    if idline >= len then
      idline - 1
    else
      let dline = dlines.(idline) in
      let size = dline.range.size in
      let eol = i + size in
      if eol > ichar then
        idline
      else
        iter dlines len ichar (idline+1) eol
  in
  fun line ichar ->
   match line.dlines with
    | [| |] -> assert false
    | dlines ->
        let len = Array.length dlines in
        let idline = iter dlines len ichar 0 0 in
        (idline, line.dlines.(idline))

type cursor = {
    mutable position : B.line_offset ;
    mutable font : Font.font ;
    mutable props : Props.t ;
  }

let pp_cursor ppf c =
  Format.fprintf ppf "{position=%a}" B.pp_line_offset c.position

let char_props_of_regions char_offset (c:char) regions =
  List.fold_left
    (fun (acc_merged, props) (i1, i2, rprops) ->
      if char_offset >= i1 && char_offset < i2 then
         (true, Props.merge props rprops)
       else
         (acc_merged, props))
    (false, c.props) regions

let mk_char_texture =
  let mk rend (c:char) props =
    match
      (let fg_color = Props.(get props fg_color) in
       Font.render_glyph_blended c.font c.glyph
         (Color.to_sdl_color fg_color)
      )[@landmark "render_char_surface"]
    with
    | Error (`Msg msg) ->
        err (fun m -> m "While rendering glyph %d with %s: %s (glyph is provided: %b)" c.glyph
           (Font.font_face_family_name c.font) msg (Font.glyph_is_provided c.font c.glyph));
        let> t = Sdl.(create_texture rend Pixel.format_rgba8888 Texture.access_static ~w:10 ~h:10) in
        Texture.finalise_sdl_texture t ;
        t
    | Ok surface ->
        let> t =
          (Sdl.create_texture_from_surface rend surface)
            [@landmark "render_char_create_texture"]
        in
        Texture.finalise_sdl_texture t ;
        t
  in
  fun rend ?props (c:char) ->
    match props with
    | Some props ->
        (* do not use cached texture *)
        mk rend c props
    | None ->
        match c.texture with
        | Some t -> t
        | None ->
            let t = mk rend c c.props in
            c.texture <- Some t ;
            t

(* Render char at (x,y). A clip must have been set on target to prevent drawing out
  of expected bounds. *)
let render_char rend (dline:dline) regions ~x ~y char_offset c =
  let (with_region_props, props) = char_props_of_regions char_offset c regions in
  let whole_r = { G.x ; y ; w = c.w ; h = dline.h } in
  let char_r = { whole_r with
      y = y + dline.baseline - c.font_ascent ;
      h = c.font_ascent - c.font_descent (* font_descent is negative *)
    }
  in
  (*debug
   (fun m -> m "render_char off_y=%d rg=%a x=%d c=%s c.font_descent=%d r=%a char_r=%a"
     off_y G.pp rg x
       (Utf8.string_of_uchar (Uchar.of_int c.glyph))
       c.font_descent
       G.pp r G.pp char_r);
  *)
  let () =
    (match Props.(opt props bg_color) with
     | None -> ()
     | Some color ->
         let r =
           if Props.(get props selected) then whole_r else char_r
         in
         Render.fill_rect rend (Some r) color
    );
    let t =
      let props = if with_region_props then Some props else None in
      mk_char_texture rend ?props c
    in
    let src = { char_r with x = 0 ; y = 0 } in
    let> () = Render.render_copy rend ~src ~dst:char_r t in
    ()
  in
  x + c.w

let linechar_regions_by_line =
  let f iline (({B.line=l1; offset=o1}, {B.line=l2; offset=o2}), props) acc =
    if iline < l1 || iline > l2 then
      acc
    else
      if l1 = l2 then
        (o1, o2, props) :: acc
      else
        if iline = l1 then
          (o1, max_int, props) :: acc
        else
          if iline = l2 then
            (0, o2, props) :: acc
          else
            (0, max_int, props) :: acc
  in
  fun regions iline -> List.fold_right (f iline) regions []

let regions_in_dline dline regions =
  let start, stop =
    let s = dline.range.start in
    s, s + dline.range.size
  in
  let f (rstart, rstop, _props) =
    not (rstop < start || rstart >= stop)
  in
  List.filter f regions

let dline_texture rend bgcolor line dline =
  match dline.texture with
  | Some t -> t
  | None ->
      debug (fun m -> m "dline_texture: recreating texture");
      let acc_x = ref 0 in
      let t =
        Texture.with_renderer (fun rend ->
           let> t = Sdl.create_texture rend
             Sdl.Pixel.format_rgba8888
               Sdl.Texture.access_target ~w:dline.w ~h:dline.h
           in
           Texture.finalise_sdl_texture t ;
           Sdl.set_render_target rend (Some t) ;
           let () = Render.with_color rend bgcolor
             (fun rend ->
                let> () = Sdl.render_fill_rect rend None in
                ()
             )
           in
           for i = 0 to dline.range.size - 1 do
             let i = dline.range.start + i in
             let c = line.chars.(i) in
             let x = render_char rend dline [] ~x:!acc_x ~y:0 i c in
             acc_x := x;
           done;
           t
        ) rend
      in
      dline.texture <- Some t;
      t

let render_dline rend ~g_text ~offset rg bg_color regions iline line ?wrap_char dline idline =
  (* rg and g_text have the same origin *)
  debug (fun m -> m "render_dline iline=%d dline.y=%d, g_text=%a rg=%a, bg_color=%a dline.range=%a"
     iline dline.y G.pp g_text G.pp rg Color.pp bg_color Rope.pp_range dline.range);
  let (off_x, off_y) = offset in
  let r =
    let dline_w = dline.w +
      (match wrap_char with
       | None -> 0
       | Some (c:char) -> c.w)
    in
    G.{ g_text with y = g_text.y + dline.y ; w = dline_w ; h = dline.h }
  in
  let acc_x =
    match G.inter rg r with
    | None -> r.x
    | Some _ when r.w <= 0 -> r.x
    | Some bg ->
        debug (fun m -> m "render_dline: G.inter %a %a = %a" G.pp rg G.pp r G.pp bg);
        let clip = G.translate ~x:off_x ~y:off_y rg in
        let clip = G.to_rect clip in
        Render.with_clip rend clip
          (fun rend ->
             let acc_x = ref r.x in
             (match regions_in_dline dline regions with
              | [] -> (* render dline with cached texture *)
                  debug (fun m -> m "rendering dline %d/%d with cached texture" iline idline);
                  let t = dline_texture rend bg_color line dline in
                  let src = { G.x = 0 ; y = 0; w = dline.w ; h = dline.h } in
                  let dst = G.translate
                    ~x:off_x ~y:off_y { src with x = r.x ; y = r.y }
                  in
                  debug (fun m -> m "copying dline texture src=%a dst=%a" G.pp src G.pp dst);
                  let> () = Render.render_copy rend ~src ~dst t in
                  acc_x := !acc_x + dline.w
              | regions -> (* render dline char by char *)
                  Render.fill_rect rend
                  (Some (G.translate ~x:off_x ~y:off_y bg)) bg_color;
                  acc_x := r.x + off_x ;
                  let y = r.y + off_y in
                  for i = 0 to dline.range.size - 1 do
                    let i = dline.range.start + i in
                    let c = line.chars.(i) in
                    let x = render_char rend dline regions ~x:!acc_x ~y i c in
                    acc_x := x;
                  done;
                  acc_x := !acc_x - off_x ;
             );
             (match wrap_char with
              | None -> ()
              | Some c ->
                  let x = render_char rend dline regions
                    ~x:(!acc_x+off_x) ~y:(r.y + off_y) (-1) c
                  in
                  acc_x := x - off_x;
             );
             !acc_x
          )
  in
  let props = List.fold_left
    (fun acc (_,i,p) -> if i = max_int then Props.merge acc p else acc)
      (Props.empty()) regions
  in
  (* if end of line is selected, fill rest of the line
     with selected color *)
  let bg_color =
    if Props.(get props selected) then
      match Props.(opt props bg_color) with
      | None -> bg_color
      | Some c -> c
    else
      bg_color
  in
  let (off_x, off_y) = offset in
  let x = max acc_x rg.x in
  let r = G.{ x ; y = r.y ; w = max 0 (rg.w - x) ; h = dline.h } in
  match G.inter rg r with
  | None -> ()
  | Some r ->
      let r = G.translate ~x:off_x ~y:off_y r in
      Render.fill_rect rend (Some r) bg_color

let render_line rend ?wrap_char ~g_text ~offset rg bg_color regions iline line =
  let regions = linechar_regions_by_line regions iline in
  let nb_dlines = Array.length line.dlines in
  Array.iteri
    (fun i dline ->
       let wrap_char = if i+1 < nb_dlines then wrap_char else None in
       render_dline rend ~g_text ~offset rg bg_color regions iline line
         ?wrap_char dline i)
    line.dlines

let line_of_y =
  let rec iter lines y left right =
    if left >= right then
      right
    else
      (
       let i = (left + right) / 2 in
       let line = lines.(i) in
       let liney = line_y line in
       let lineh = line_height line in
       if liney + lineh <= y then
         iter lines y (i+1) right
       else
         if y < liney then
           iter lines y left i
         else
           i
      )
  in
  fun lines y ->
    let len = Array.length lines in
    assert (len > 0);
    iter lines y 0 (len-1)

let dline_of_y =
  let rec iter dlines len i y =
    if i >= len then
      (i-1)
    else
      (
       let dline = dlines.(i) in
       (*[%debug "dlines.(%d).y=%d, .h=%d, y=%d"
          i dline.y dline.h y);*)
       if dline.y <= y && dline.y + dline.h >= y
       then i
       else iter dlines len (i+1) y
      )
  in
  fun lines y ->
    let iline = line_of_y lines y in
    let line = lines.(iline) in
    let len = Array.length line.dlines in
    if len <= 0 then
      assert false
    else
      (iline, iter line.dlines len 0 y)


let empty_line props =
  let font = Props.get_font props in
  let dline =
    { y = 0;
      h = Font.font_height font ;
      baseline = Font.font_ascent font ;
      w = 0 ;
      range = Rope.range ~start: 0 ~size:0 ;
      texture = None ;
    }
  in
  { chars = [| |] ; dlines = [| dline |] }

module Props_cache =
  struct
    module M = Map.Make(Texttag.TSet)
    type t = {
        mutable font : Font.font_desc ;
        mutable theme : Texttag.Theme.t ;
        mutable cache : Props.t M.t ;
      }
    let create () =
      let theme = Texttag.Theme.create () in
      { font = Font.font_desc "" ;
        theme ;
        cache = M.empty ;
      }

    let get t def_props theme tags langtag =
      let fd = Props.(get def_props font_desc) in
      if not (Texttag.Theme.equal t.theme theme &&
        (Font.font_desc_compare t.font fd = 0))
      then
        (
         (* reset cache *)
         t.cache <- M.empty ;
         t.font <- fd ;
         t.theme <- theme ;
        );
      let tags =
        match langtag with
        | None -> tags
        | Some t -> Texttag.TSet.add tags t
      in
      match M.find_opt tags t.cache with
      | Some p -> p
      | None ->
          let p = Texttag.Theme.merge_tag_props theme tags def_props in
          t.cache <- M.add tags p t.cache ;
          p
  end
let compute_char_props def_props props_cache theme (tags, langtag) =
  Props_cache.get props_cache def_props theme tags langtag

let finalise_char c =
(*  let f (c:char) =
    try Option.iter Sdl.destroy_texture c.texture
    with _ -> ()
  in
  Gc.finalise f
*)
  ()

let finalise_dline l =
(*  let f (dl:dline) =
    try Option.iter Sdl.destroy_texture dl.texture
    with _ -> ()
  in
  Gc.finalise f
*)
  ()

let mk_char def_props props_cache theme tags c =
  let props = compute_char_props def_props props_cache theme tags in
  let font = Props.get_font_for_char props c in
  let font_ascent = Font.font_ascent font in
  let font_descent = Font.font_descent font in
  let h = Font.font_height font in
  let cp = Uchar.to_int c in
  let (cp, is_tab) =
    if cp = 9 (* tab *) then
      (32 (* space *), true)
    else
      (cp, false)
  in
  match Font.glyph_metrics font cp with
  | Error (`Msg msg) ->
      Log.err (fun m -> m "Could not get glyph metrics for %d in font %s: %s"
         cp (Font.font_face_family_name font) msg);
      let c = { w = 10 ; h ; glyph = cp ;
          font ; font_ascent ; font_descent ; props ;
          texture = None }
      in
      c
  | Ok g ->
      let w = g.Ttf.GlyphMetrics.advance in
      let w = if is_tab then 2*w else w in
      (*let> (w,h) = Ttf.size_utf8 font (Utf8.string_of_uchar c) in*)
      let c = { w ; h ; glyph = cp ;
          font ; font_ascent ; font_descent ; props ;
          texture = None }
      in
      finalise_char c;
      c

let update_line =
  let rec iter line def_props props_cache theme start stop
    width_changed acc_w acc_h acc_ascent istop i chars =
    if i >= istop then
      (width_changed, acc_w, acc_h, acc_ascent, chars)
    else
      match chars with
      | [] ->
          Log.warn (fun m -> m "Textview.update_line: empty_chars");
          (width_changed, acc_w, acc_h, acc_ascent, chars)
      | (c, tags) :: q ->
          let oldc = line.chars.(i) in
          let (width_changed, c) =
            if i >= start && i <= stop then
              (
               let c = mk_char def_props props_cache theme tags c in
               let width_changed = width_changed || (c.w <> oldc.w) in
               line.chars.(i) <- c;
               (width_changed, c)
              )
            else
              (width_changed, oldc)
          in
          iter line def_props props_cache theme start stop width_changed
            (acc_w + c.w) (max acc_h c.h) (max acc_ascent c.font_ascent)
            istop (i+1) q
  in
  let rec iter_dlines line def_props props_cache theme start stop len_dlines
    width_changed acc_h idline chars =
    if idline >= len_dlines then
      width_changed
    else
      (
       let dline = line.dlines.(idline) in
       free_dline_texture dline ;
       let (width_changed, w, max_h, baseline, chars) =
         iter line def_props props_cache theme start stop
           width_changed 0 0 0
           (dline.range.start + dline.range.size) dline.range.start chars
       in
       let dline = { dline with
           y = acc_h ; h = max_h ; baseline ; w ;
         }
       in
       line.dlines.(idline) <- dline;
       iter_dlines line def_props props_cache theme start stop len_dlines
         width_changed (acc_h + max_h) (idline+1) chars
      )
  in
  fun def_props props_cache theme buffer line ->
    let len = Array.length line.chars in
    fun ?(start=0) ?(stop=len - 1) iline ->
      let def_props = Props.dup def_props in
      (* do not use textview bg_color, so that we can highlight
         current line. *)
      Props.(set_opt def_props bg_color None);
      let chars = B.line_chars ~map_out:false buffer iline in
      match chars with
      | [] -> (* empty line, do not changed its height and baseline *)
          false
      | _ ->
          let len_dlines = Array.length line.dlines in
          let width_changed = iter_dlines
            line def_props props_cache theme start stop len_dlines
            false 0 0 chars
          in
          width_changed

let mk_line def_props memoize_props theme buffer pos =
  let def_props = Props.dup def_props in
  (* do not use textview bg_color, so that we can highlight
     current line. *)
  Props.(set_opt def_props bg_color None);
  let chars = B.line_chars ~map_out: false buffer pos in
  (*debug (fun m -> m "line.(%d) = %a" pos B.pp_range buffer.B.lines.(pos));*)
  match chars with
  | [] when pos = 0 -> empty_line def_props
  | [] ->
      (* build an empty line with props of previous newline char *)
      let lines = B.lines buffer in
      let range = lines.(pos) in
      (match B.chars ~map_out:false ~start:(range.Rope.start-1) ~size:1 buffer with
       | [_,tags] ->
           let props = compute_char_props def_props memoize_props theme tags in
           empty_line props
       | _ -> assert false
      )
  | _ ->
      let (w, max_h, max_ascent, chars) = List.fold_left
        (fun (acc_w, acc_h, acc_ascent, acc) (c,tags) ->
           let c = mk_char def_props memoize_props theme tags c in
           (acc_w + c.w, max acc_h c.h, max acc_ascent c.font_ascent, c :: acc)
        )
          (0, 0, 0, []) chars
      in
      let chars = Array.of_list (List.rev chars) in
      let baseline = max_ascent in
      let dline = { y = 0 ; h = max_h ; baseline ; w ;
          range = Rope.range ~start:0 ~size:(Array.length chars) ;
          texture = None ;}
      in
      { dlines = [| dline |] ; chars }

let arrange_line =
  let rec mk_dlines ~max_w (wrap_c:char option) dlines
    ~w ~h ~ascent ~start ~size chars ~len ~pos =
    let (wrap_w, wrap_h, wrap_ascent) =
      match wrap_c with
      | None -> (0, 0, 0)
      | Some c -> c.w, c.h, c.font_ascent
    in
    if pos >= len then
      let dline = {
          w ; h ; baseline = ascent ;
          y = 0 ; range = Rope.range ~start ~size ;
          texture = None ;
        }
      in
      List.rev (dline :: dlines)
    else
      let (c:char) = chars.(pos) in
      let cw = c.w in
      (* does this char fit on the line ? *)
      if w + cw <= max_w then
        (* if there is a next char, does it fit on the line ? if so
           does the wrap char fit on the remaining space ? if not, we
           should not add current char. *)
        if pos + 1 < len then
          let c2w = chars.(pos+1).w in
          let c3w = if pos + 2 < len then chars.(pos+2).w else 0 in
          if w + cw + c2w + wrap_w <= max_w
            || w + cw + c2w + c3w <= max_w
          then
            mk_dlines ~max_w wrap_c dlines ~w:(w+cw)
              ~h:(max h c.h) ~ascent:(max ascent c.font_ascent)
              ~start ~size:(size+1) chars ~len ~pos:(pos+1)
          else
            (* can't put this char and next one; let's see if we
               can put this char + wrap char of if we must wrap now.
               Do not wrap if the line is empty, or this we'll
               loop forever  *)
            if w + cw + wrap_w <= max_w || size <= 0 then
              let dline = {
                  w = w + cw + wrap_w ;
                  h = max h (max c.h wrap_h);
                  baseline = max ascent (max c.font_ascent wrap_ascent);
                  y = 0 ; range = Rope.range ~start ~size:(size+1) ;
                  texture = None }
              in
              mk_dlines ~max_w wrap_c (dline::dlines)
                ~w:0 ~h:0 ~ascent:0 ~start:(start+size+1) ~size:0 chars
                ~len ~pos:(pos+1)
            else
              let dline = { w ; h ; baseline = ascent ;
                  y = 0 ; range = Rope.range ~start ~size ;
                  texture = None }
              in
              mk_dlines ~max_w wrap_c (dline::dlines)
                ~w:0 ~h:0 ~ascent:0 ~start:(start+size) ~size:0
                chars ~len ~pos
        else
          (* this is last char *)
          let dline = {
              w = w+cw ;
              h = max h c.h ;
              baseline = max ascent c.font_ascent;
              y = 0 ;
              range = Rope.range ~start ~size:(size+1) ;
              texture = None }
          in
          List.rev (dline::dlines)
      else
        (* if there was no char on the line, do not put a wrap here,
           but simply put the char *)
        if size = 0 then
          mk_dlines ~max_w wrap_c dlines ~w:(w+cw)
            ~h:(max h c.h) ~ascent:(max ascent c.font_ascent)
            ~start ~size:(size+1)
            chars ~len ~pos:(pos+1)
        else
          (* wrap *)
          let dline =
            { w = w + wrap_w;
              h = max h wrap_h;
              baseline = max ascent wrap_ascent;
              y = 0 ; range = Rope.range ~start ~size ;
              texture = None }
          in
          mk_dlines ~max_w wrap_c (dline::dlines)
            ~w:0 ~h:0 ~ascent:0 ~start:(start+size) ~size:0
            chars ~len ~pos
  in
  fun line wrap_mode wrap_c max_width ->
    match wrap_mode with
    | Wrap_none ->
        (
         match line.dlines with
         | [| |] -> assert false
         | [| dline |] -> ()
         | _ ->
             let dlines = mk_dlines max_int wrap_c [] 0 0 0 0 0
               line.chars (Array.length line.chars) 0
             in
             line.dlines <- (Array.of_list dlines)
        )
    | Wrap_char ->
        match Array.length line.chars with
        | 0 ->
            (* no char, do not try to arrange chars or height will be set to 0 *)
            ()
        | _ ->
            let dlines = mk_dlines max_width wrap_c [] 0 0 0 0 0
              line.chars (Array.length line.chars) 0
            in
            line.dlines <- Array.of_list dlines


(* Return optional character (None means y is beyond last char)
  with x-position of this character. *)
let char_of_x =
  let rec iter (chars:char array) ~len ~x ~start ~px ~i =
    if i >= len then
      None
    else
      let c = chars.(i) in
      if px + c.w >= x then
        Some (i-start)
      else
        iter chars ~len ~x ~start ~px:(px+c.w) ~i:(i+1)
  in
  fun chars ~start ~x ->
    let len = Array.length chars in
    iter chars ~len ~x ~start ~px:0 ~i:start

let render_gutter_line_bg rend ~offset:(x,y) rg ~xbase ~width bg_color line =
  let r = G.{ x = xbase; y = line_y line ; w = width ; h = line_height line } in
  debug (fun m -> m "render_gutter_line_bg rg=%a, r=%a, offset=(%d,%d)"
     G.pp rg G.pp r x y);
  match G.inter r rg with
  | None -> ()
  | Some r ->
      Render.fill_rect rend (Some (G.translate ~x ~y r)) bg_color

let render_gutter_line_number rend ~offset:(x,y) rg ~xbase ~width
  ~fg_color font iline line =
  let> surface = Font.render_utf8_blended font (string_of_int (iline + 1))
    (Color.to_sdl_color fg_color)
  in
  let> t = Sdl.create_texture_from_surface rend surface in
  Texture.finalise_sdl_texture t ;
  let> (_,_,(w,h)) = Sdl.query_texture t in
  let r = G.{ x = xbase + width - w; y = line_y line ; w ; h } in
  match G.inter r rg with
  | None -> ()
  | Some rgsrc ->
      let src_x = max 0 rgsrc.x - r.x in
      let src_y = max 0 rgsrc.y - r.y in
      let src = G.{ x = src_x ; y = src_y ;
          w = min r.w rgsrc.w ;
          h = min r.h rgsrc.h }
      in
      let dst =
        let dst = { src with x = rgsrc.x ; y = rgsrc.y } in
        G.translate ~x ~y dst
      in
      let> () = Render.render_copy rend ~src ~dst t in
      ()

(**/**)

(** {2 Textview widget} *)

(** A widget to display the contents of a {{!Textbuffer.t}text buffer}.
  If no [buffer] is provided, a new one is created.
*)
class textview ?classes ?name ?props ?wdata ?buffer () =
  let buffer = match buffer with
    | None -> B.create ()
    | Some b -> b
  in
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    method as_textview = (self :> textview)

    (**/**)

    method kind = "textview"

    (** geometry of text from g_inner *)
    val mutable g_text = G.zero

    (** width of line numbers gutter *)
    val mutable w_lnums = 0

    (** width of line markers gutter *)
    val mutable w_markers = 0

    val mutable gutter_font = None

    val props_cache = Props_cache.create ()

    (* to prevent asking parent to show the widget from the top-left corner *)
    method! show = ()

    val mutable handled_tags = Texttag.TSet.empty
    val mutable theme = Texttag.Theme.create ()

    val mutable lines = ([| |] : line array)
    val mutable cursors = B.Cursor_map.empty
    val mutable insert_cursor = (None : B.cursor option)
    val mutable selection_cursor = (None : B.cursor option)
    val mutable state_machine = Misc.empty_state_machine
    val mutable wrap_char = None
    val mutable buffer = buffer

    method! themable_props = gutter_props :: super#themable_props

    method! css_atts = Smap.singleton "theme" self#tagtheme

    method! private do_apply_theme_more apply mypath inh =
      Texttag.TSet.iter (fun tag ->
         let name = Texttag.T.name tag in
         (*Log.warn (fun m -> m "%s (classes=%s) theming named property %S"
            self#me (String.concat "," (Sset.elements self#classes)) name);*)
         let path = (name, Smap.empty, None) :: mypath in
         (* do not make tags inherit props *)
         (*let inh = Css.(P.filter (fun (C.Computed.B (p,_)) -> P.is_var p)) inh in*)
         let cprops = apply path inh (*Css.C.empty*) in
         (*Log.warn (fun m -> m "cprops for %S= %a" name Props.pp cprops);*)
         Texttag.Theme.set_tag theme tag cprops
      )
        handled_tags

    method! private do_apply_theme ~root ~parent parent_path rules =
      [%debug "%s#do_apply_theme (tagtheme=%S)" self#me self#tagtheme];
      let old_tagtheme = self#tagtheme in
      let old_theme = theme in
      let old_props = Props.dup self#props in
      theme <- Texttag.Theme.create ();
      super#do_apply_theme ~root ~parent parent_path rules;
      if self#tagtheme <> old_tagtheme then
        (* tagtheme changed when applying theme, so we restore previous theme
           and apply again with new tagtheme *)
        (
         theme <- old_theme ;
         self#do_apply_theme ~root ~parent parent_path rules ;
        )
      else
        (
         (*Log.warn (fun m -> m "%sdo_apply_theme theme=%a" self#me Texttag.Theme.pp theme);*)
         let gf = Props.get_font (self#get_p gutter_props) in
         gutter_font <- Some gf;
         (* need to rebuild all items to apply new props if textview props or tag props changed *)
         if Props.compare self#props old_props <> 0
           || Texttag.Theme.tags_props_differ old_theme theme
         then
           self#ignore_need_resize_do (fun () -> self#build_items)
         else
           (
            (* finally do not change theme, so that props cache can be used *)
            [%debug "no change in props, not rebuilding items"];
            theme <- old_theme
           )
        )

    (**/**)

    (** {2 Properties} *)

    method tagtheme = self#get_p Texttag.Theme.prop
    method set_tagtheme = self#set_p Texttag.Theme.prop

    method editable = self#get_p Props.editable
    method set_editable b = self#set_p Props.editable b

    method cursor_width = self#get_p Props.cursor_width
    method set_cursor_width = self#set_p Props.cursor_width

    method show_cursors = self#get_p show_cursors
    method set_show_cursors b = self#set_p show_cursors b

    method show_line_numbers = self#get_p show_line_numbers
    method set_show_line_numbers b = self#set_p show_line_numbers b

    method show_line_markers = self#get_p show_line_markers
    method set_show_line_markers b = self#set_p show_line_markers b

    method highlight_current_line = self#get_p highlight_current_line
    method set_highlight_current_line b = self#set_p highlight_current_line b

    method wrap_mode = self#get_p wrap_mode
    method set_wrap_mode = self#set_p wrap_mode


    (**/**)
    method update_wrap_char =
      let props = Props.dup props in
      Props.(set_opt props bg_color None);
      let c = mk_char props props_cache theme Rope.no_tag
        (Uchar.of_int (self#get_p wrap_char_codepoint))
      in
      wrap_char <- Some c

    method! set_geometry geom =
      let old_w = g_text.w in
      super#set_geometry geom ;
      debug (fun m -> m "%s#set_geometry: g=%a, g_inner=%a, g_text=%a"
         self#me G.pp g G.pp g_inner G.pp g_text);
      self#update_gutter_widths;
      if g_text.w <> old_w then
        self#arrange_lines

    (**/**)

    (** {2:handled_tags Handled tags}

      Theme is applied only to handled tags, not all defined tags. Tags in textbuffer
      which are not handled by a textview are ignored.
      Beware that changing the handled tags does not trigger re-theming
      (i.e. [#apply_theme] is not called).
    *)

    method add_handled_tag tag = handled_tags <- Texttag.TSet.add handled_tags tag
    method rem_handled_tag tag = handled_tags <- Texttag.TSet.remove handled_tags tag
    method set_handled_tags tags = handled_tags <- tags

    (** {2 Buffer} *)

    method buffer = buffer
    method set_buffer b =
      if b != buffer then
        (
         B.unregister_widget buffer self#as_widget;
         buffer <- b;
         self#init_with_buffer ;
         self#scroll_to_cursor ();
        )
      else
        Log.warn (fun m -> m "%s#set_buffer: same buffer" self#me)

    (** Returns the number of lines in the buffer. *)
    method line_count = B.line_count buffer

    (** Returns the number of characters in the buffer. *)
    method char_count = B.size buffer

    (** [v#text ()] returns contents of the buffer as a string.
      Optional arguments:
      {ul
       {- [start]: the start of range to retrieve (default is [0]).}
       {- [size]: the size of range to retrieve. }
       {- [stop]: if [size] is not provided, the end of the range to retrieve.}
      }
    *)
    method text ?(start=0) ?size ?stop () =
      let size =
        match size with
        | Some n -> n
        | None ->
            let stop =
              match stop with
              | None -> B.size buffer
              | Some s -> s
            in
            if start > stop then
              (
               Log.warn (fun m -> m "%s#text start(%d) > stop(%d)" self#me start stop);
               0
              )
            else
              (stop - start)
      in
      B.to_string ~start ~size buffer

    (** Set source language of the textbuffer used by the textview.
      This also adds the language tags ({!Texttag.Lang.tags}) to the
      handled tags of the textview. *)
    method set_source_language lang =
      B.set_source_language buffer lang;
      List.iter self#add_handled_tag Texttag.Lang.tags

    method source_language = B.source_language buffer

    (** {2 Cursors} *)

    (** Returns the insert cursor. The insert cursor is the cursor where
      text is inserted when user types in. It is also the default cursor for
      methods accepting a cursor as optional argument. A textview must always
      have a current insert cursor. Raises [Not_found] if there is not insert
      cursor. *)
    method insert_cursor =
      match insert_cursor with
      | None ->
          err (fun m -> m "%s: no insert cursor!" self#me);
          raise Not_found
      | Some c -> c

    (** Set the insert cursor. *)
    method set_insert_cursor c =
      match self#get_cursor c with
      | None ->  false
      | Some _ ->
          insert_cursor <- Some c;
          true

    (** [v#is_insert_cursor c] returns [true] is [c] is the current insert cursor. *)
    method is_insert_cursor id =
      match insert_cursor with
      | Some id2 -> B.compare_cursor id id2 = 0
      | None -> false

    (** The insert cursor and selection cursor are the bounds of the current
      selection. A textview must always have a selection cursor, created
      when the widget is created. Raises [Not_found] if there is no
      selection cursor. *)
    method selection_cursor =
      match selection_cursor with
      | None ->
          err (fun m -> m "%s: no selection cursor!" self#me);
          raise Not_found
      | Some c -> c

    (** Returns the given cursor offset. *)
    method cursor_offset c =
      match self#get_cursor c with
      | None -> 0
      | Some c -> c.position.B.bol + c.position.B.offset

    (** Returns the given cursor position as {!Textbuffer.type-line_offset}. *)
    method cursor_line_offset c =
      match self#get_cursor c with
      | None -> B.line_offset ~line:0 ~bol:0 ~offset:0
      | Some c -> c.position

    (**/**)
    method private get_cursor c =
      match B.Cursor_map.find_opt c cursors with
      | None ->
          Log.warn
            (fun m -> m "%s#use_cursor: No such cursor %a in view"
               self#me B.pp_cursor_id c);
          None
      | Some c -> Some c
    (**/**)

    (** [add_cursor ()] creates a new cursor. [props] can be provided to specify
      properties for this cursor (like its color). See {!Textbuffer.val-create_cursor}
      for other arguments. *)
    method add_cursor ?(props=Props.dup props) ?gravity ?line ?char ?offset () =
      let c = B.create_cursor ~widget:self#id ?gravity ?line ?char ?offset buffer in
      let position = B.cursor_line_offset buffer c in
      let font = Props.get_font props in
      let cur = { position ; props ; font } in
      cursors <- B.Cursor_map.add c cur cursors;
      self#need_render_line position.line ;
      c

    (** Removes the given cursor. Beware when removing the insert cursor, it should
        be replaced by another one. *)
    method remove_cursor c =
      match self#get_cursor c with
      | None -> ()
      | Some cur ->
          if self#is_insert_cursor c then insert_cursor <- None ;
          B.remove_cursor buffer c ;
          cursors <- B.Cursor_map.remove c cursors;
          self#need_render_line cur.position.line

    (** Move selection cursor at the same position than the insert cursor. *)
    method sel_to_ins_cursor =
      B.move_cursor_to_cursor buffer
        ~src:self#insert_cursor ~dst:self#selection_cursor

    (** Make sure the insert cursor (or the cursor given with argument [c])
       is in the displayed area. *)
    method scroll_to_cursor ?(c=self#insert_cursor) () =
      match self#get_cursor c with
      | None -> ()
      | Some c ->
          let rect = self#cursor_rect c in
          let rect = G.translate ~x:g_text.x ~y:g_text.y rect in
          debug (fun m -> m "%s#scroll_to_cursor c=%a, rect=%a" self#me
             pp_cursor c G.pp rect);
          self#show_child_rect rect

    (** {2 Moving cursors}

    The following methods moves by default the insert cursor, or
    the selection cursor if a shift key is pressed.
    The optional argument [c] can be used to move another cursor.

    The methods return the new offset of the cursor, or [None] if
    the cursor is invalid.
 *)

    (** Moves cursor to beginning of the line where the cursor is. *)
    method move_to_line_start ?(c=self#ins_or_sel_cursor) () =
      let x = B.move_cursor_to_line_start buffer c in
      self#set_selection_opt c;
      x

    (** Moves cursor to the end (before the newline character) of the line
       where the cursor is. *)
    method move_to_line_end ?(c=self#ins_or_sel_cursor) () =
      let x = B.move_cursor_to_line_end buffer c in
      self#set_selection_opt c ;
      x

    (** Moves cursor to next line. *)
    method line_forward ?(c=self#ins_or_sel_cursor) n =
      let x = B.line_forward_cursor buffer c n in
      self#set_selection_opt c;
      x

    (** Moves cursor to previous line. *)
    method line_backward ?c n = self#line_forward ?c (-n)

    method private next_dline ?(strict=false) ~iline ~idline n =
      let rec iter ~iline line ~idline i =
        if i <= 0 then
          Some (iline, idline)
        else
          let len = Array.length line.dlines in
          if idline + i < len then
            Some (iline, idline + i)
          else
            let iline2 = iline + 1 in
            if iline2 < Array.length lines then
              (
               let i = i - (len - idline) in
               iter ~iline:iline2 lines.(iline2) ~idline:0 i
              )
            else
              if strict then
                None
              else
                Some (iline, len - 1)
      in
      iter ~iline lines.(iline) ~idline n

    method private prev_dline ?(strict=false) ~iline ~idline n =
      let rec iter ~iline line ~idline i =
        if i <= 0 then
          Some (iline, idline)
        else
          if idline - i >= 0 then
            Some (iline, idline - i)
          else
            let iline2 = iline - 1 in
            if iline2 >= 0 then
              let i = i - idline - 1 in
              let line2 = lines.(iline2) in
              let idline = Array.length line2.dlines - 1 in
              iter ~iline:iline2 line2 ~idline i
            else
              if strict then
                None
              else
                Some (iline, 0)
      in
      iter ~iline lines.(iline) ~idline n

    (** Moves cursor to next "display line", i.e. next part of the line
      is the line is wrapped and the cursor is not in the last part of
      the line, or the next line. *)
    method dline_forward ?(c=self#ins_or_sel_cursor) n =
      let cid = c in
      match self#get_cursor c with
      | None -> None
      | Some c ->
          let iline = c.position.B.line in
          let line = lines.(iline) in
          let (idline, dline) = dline_of_char line c.position.B.offset in
          match self#next_dline iline idline 1 with
          | None -> None
          | Some (iline2, idline2) ->
              let line2 = lines.(iline2) in
              let dline2 = line2.dlines.(idline2) in
              let pos_on_dline1 = c.position.B.offset - dline.range.start in
              let pos_on_dline2 = min pos_on_dline1 dline2.range.size in
              let diff =
                if iline = iline2 then
                  (dline.range.size - pos_on_dline1 + pos_on_dline2)
                else
                  let off1 = c.position.B.bol + c.position.B.offset in
                  let pos_on_line2 = dline2.range.start + pos_on_dline2 in
                  let off2 =
                    B.offset_of_line_char buffer ~line:iline2 ~char:pos_on_line2
                  in
                  (off2 - off1)
              in
              let off = B.forward_cursor buffer cid diff in
              (*warn (fun m -> m "new cursor offset: %d" (Option.value off ~default:(-1)));*)
              self#set_selection_opt cid;
              off

    (** Moves cursor to previous "display line", i.e. the previous part
     of the line if the line is wrapped and the cursor is not in the first
     part, or the previous line. *)
    method dline_backward ?(c=self#ins_or_sel_cursor) n =
      let cid = c in
      match self#get_cursor c with
      | None -> None
      | Some c ->
          let iline = c.position.B.line in
          let line = lines.(iline) in
          let (idline, dline) = dline_of_char line c.position.B.offset in
          match self#prev_dline iline idline 1 with
          | None -> None
          | Some (iline2, idline2) ->
              (*warn (fun m -> m "prev_dline (%d,%d) => (%d,%d)" iline idline iline2 idline2);*)
              let line2 = lines.(iline2) in
              let dline2 = line2.dlines.(idline2) in
              let pos_on_dline1 = c.position.B.offset - dline.range.start in
              let pos_on_dline2 = min pos_on_dline1 dline2.range.size in
              let diff =
                if iline = iline2 then
                  (pos_on_dline1 + (dline2.range.size - pos_on_dline2))
                else
                  let off1 = c.position.B.bol + c.position.B.offset in
                  let off2 =
                    let pos_on_line2 = dline2.range.start + pos_on_dline2 in
                    B.offset_of_line_char buffer
                      ~line:iline2 ~char:pos_on_line2
                  in
                  (off1 - off2)
              in
              let off = B.backward_cursor buffer cid diff in
              self#set_selection_opt cid;
              off

    (** [v#char_forward n] moves cursor [n] characters forward. *)
    method char_forward ?(c=self#ins_or_sel_cursor) n =
      let x = B.forward_cursor buffer c n in
      self#set_selection_opt c;
      x

    (** [v#char_backward n] moves cursor [n] characters backward. *)
    method char_backward ?c n = self#char_forward ?c (-n)

    (** Moves cursor to next word end, according to waht is a
      word character in the buffer (see {!Textbuffer.word_chars}).
    *)
    method forward_to_word_end ?(c=self#ins_or_sel_cursor) () =
      let x = B.forward_cursor_to_word_end buffer c in
      self#set_selection_opt c;
      x

    (** Moves cursor to previous word start. *)
    method backward_to_word_start ?(c=self#ins_or_sel_cursor) () =
      let x = B.backward_cursor_to_word_start buffer c in
      self#set_selection_opt c;
      x

    (** [v#move_cursor ()] moves cursor to position specified by optional
      arguments as explained in {!Textbuffer.move_cursor}.
    *)
    method move_cursor ?line ?char ?offset ?(c=self#ins_or_sel_cursor) () =
      let x = B.move_cursor buffer ?line ?char ?offset c in
      self#set_selection_opt c;
      x

    (** Moves cursor one page backward. Depends on the displayed size
      of the widget. Typically associated to page-up key. *)
    method page_backward ?(c=self#ins_or_sel_cursor) () =
      let cid = c in
      match self#get_cursor cid with
      | None -> None
      | Some c ->
          let vg = self#visible_rect in
          debug (fun m -> m "%s#page_backward visible_rect=%a" self#me G.pp vg);
          let line = lines.(c.position.B.line) in
          let r =
            match G.inter vg g with
            | None -> { vg with y = line_y line }
            | Some r -> G.translate
                ~x:(-g_inner.x - g_text.x)
                  ~y:(-g_inner.y - g_text.y) r
          in
          debug (fun m -> m "%s#page_backward r=%a" self#me G.pp r);
          let (idline, dline) = dline_of_char line c.position.B.offset in
          (* compute y of the dline to jump to *)
          let y = max 0 (dline.y - r.h + dline.h) in
          let iline2 = self#line_of_y y in
          let line2 = lines.(iline2) in
          let (idline2,dline2) = dline_of_char line2 c.position.B.offset in
          let pos_on_dline2 = min dline2.range.size c.position.B.offset in
          let char = dline2.range.start + pos_on_dline2 in
          (* compute y of the top visible rectangle; distance between
             new dline of cursor and new visible rect should be the same
             as between the previous dline of cursor and the previous
             visible rect *)
          let dist = dline.y - r.y in
          debug (fun m -> m "%s#page_backward dist=%d, dline.y=%d, r.y=%d"
            self#me dist dline.y r.y);
          let r = { r with y = max 0 (dline2.y - dist) } in
          let r = G.translate ~x:g_text.x ~y:g_text.y r in
          self#show_child_rect r;
          self#move_cursor ~line:iline2 ~char ~c:cid ()

    (** Moves cursor one page forward. Depends on the displayed size
      of the widget. Typically associated to page-down key. *)
    method page_forward ?(c=self#ins_or_sel_cursor) () =
      let cid = c in
      match self#get_cursor cid with
      | None -> None
      | Some c ->
          let vg = self#visible_rect in
          debug (fun m -> m "%s#page_forward visible_rect=%a" self#me G.pp vg);
          let line = lines.(c.position.B.line) in
          let r =
            match G.inter vg g with
            | None -> { vg with y = line_y line }
            | Some r -> G.translate
                ~x:(-g_inner.x - g_text.x)
                  ~y:(-g_inner.y -g_text.y) r
          in
          debug (fun m -> m "%s#page_forward r=%a" self#me G.pp r);
          let (idline, dline) = dline_of_char line c.position.B.offset in
          (* compute y of the dline to jump to *)
          let y = min g_text.h (dline.y + r.h) in
          let iline2 = self#line_of_y y in
          let line2 = lines.(iline2) in
          let (idline2,dline2) = dline_of_char line2 c.position.B.offset in
          let pos_on_dline2 = min dline2.range.size c.position.B.offset in
          let char = dline2.range.start + pos_on_dline2 in
          (* compute y of the top visible rectangle; distance between
             new dline of cursor and new visible rect should be the same
             as between the previous dline of cursor and the previous
             visible rect *)
          let dist = dline.y - r.y in
          debug (fun m -> m "%s#page_forward dist=%d, dline.y=%d, r.y=%d"
            self#me dist dline.y r.y);
          let r = { r with y = max 0 (dline2.y - dist) } in
          let r = G.translate ~x:g_text.x ~y:g_text.y r in
          self#show_child_rect r;
          self#move_cursor ~line:iline2 ~char ~c:cid ()

    (**/**)
    method private last_line =
      let len = Array.length lines in
      if len <= 0 then None else Some (lines.(len-1))

    method private update_gutter_widths =
      match gutter_font with
      | None ->
          g_text <- g_inner;
          debug (fun m -> m "%s#update_gutter_widths: no gutter font, g_text<-%a"
             self#me G.pp g_inner);
      | Some font ->
          w_lnums <-
            (if self#get_p show_line_numbers then
               let nchars = truncate (ceil (log10 (float (Array.length lines)))) in
               let str = String.make nchars '0' in
               let> (w,_) = Font.size_utf8 font str in
               w
             else
               0
            );
          w_markers <-
            (if self#get_p show_line_markers then
               let> (w,_) = Font.size_utf8 font "XX" in
               w
             else
               0
            );
          let x = self#gutter_width in
          g_text <- { y = 0 ; x ; w = g_inner.w - x ; h = g_inner.h };
          debug (fun m -> m "%s#update_gutter_widths g_text<-%a" self#me G.pp g_text)

    method private gutter_width =
      let gp = Props.get props gutter_props in
      let p = Props.(get gp padding) in
      match w_lnums + w_markers with
      | 0 -> p.right
      | _ -> p.left + w_lnums + w_markers + p.right

    method! private min_width_ = super#min_width_ +
      self#gutter_width + self#cursor_width +
      match self#get_p wrap_mode with
      | Wrap_none -> Array.fold_left
          (fun acc line -> max acc (line_total_width line)) 0 lines
      | Wrap_char -> 0

    method! private min_height_ =
      debug (fun m -> m "%s#min_height_ g=%a" self#me G.pp g);
      super#min_height_
      + (match self#last_line with
         | None -> 0
         | Some l -> line_y l + line_height l)

    (* y coord is already translated to the text drawing area *)
    method private line_of_y y = line_of_y lines y

    (* y coord is already translated to the text drawing area *)
    method private dline_of_y y = dline_of_y lines y

    method private line_char_of_coords ~x ~y =
      [%debug "%s#line_char_of_coords x=%d, y=%d" self#me x y];
      let x = x - g.x - g_inner.x - g_text.x in
      let y = y - g.y - g_inner.y - g_text.y in
      let (iline, idline) = self#dline_of_y y in
      let line = lines.(iline) in
      let dline = line.dlines.(idline) in
      [%debug "%s#line_char_of_coords => x=%d, y=%d => iline=%d, idline=%d"
         self#me x y iline idline];
      let ichar = match char_of_x line.chars ~start:dline.range.start ~x with
        | Some i -> i
        | None -> dline.range.size
      in
      [%debug "%s#line_char_of_coords => ichar=%d dline.range.start=%d"
        self#me ichar dline.range.start];
      (iline, dline, ichar)

    (**/**)

    (** {2 Selection} *)

    (** Returns the selected range, if any. *)
    method selection_range =
      match self#get_cursor self#selection_cursor with
      | None -> None
      | Some sc ->
          match self#get_cursor self#insert_cursor with
          | None -> None
          | Some ic ->
              match B.compare_line_offset sc.position ic.position with
              | 0 -> None
              | _ ->
                 let (lo1, lo2) = B.order_line_offsets ic.position sc.position in
                 let start = lo1.bol + lo1.offset in
                 let size = lo2.bol + lo2.offset - start in
                 Some (Rope.range ~start ~size)

    (** Returns the selected text, or [""] if no text is selected. *)
    method selection =
      match self#selection_range with
      | None -> ""
      | Some { start ; size } -> B.to_string ~start ~size buffer

    (** Returns the selected text, if any. *)
    method selection_opt =
      match self#selection_range with
      | None -> None
      | Some { start ; size } -> Some (B.to_string ~start ~size buffer)

    (** [v#select_range ~start ~size] moves insert and selection cursors
       to select the specified range. *)
    method select_range ~start ~size =
      ignore(self#move_cursor ~offset:start ~c:self#insert_cursor ());
      ignore(self#move_cursor ~offset:(start+size) ~c:self#selection_cursor());
      self#set_selection

    (**/**)

    method private set_selection =
      Selection.set (fun () -> self#selection_opt)
    method private set_selection_opt c =
      if self#is_insert_cursor c then
          ignore(self#sel_to_ins_cursor)
        else
          self#set_selection

    (* Returns range (y0, y1) of modified y-coordinates and last
       inspected line and whether at least one line'y was changed. *)
    method update_lines_y_from ?(force_until=max_int) i =
      debug (fun m -> m "%s#update_lines_y_from i=%d" self#me i);
      let len = Array.length lines in
      let rec iter y i at_least_one_changed =
        if i >= len then
          (y, i, at_least_one_changed)
        else
          (
           let (new_y, changed) = update_line_y lines.(i) y in
           if changed || force_until >= i then
             iter new_y (i+1) (at_least_one_changed || changed)
           else
             (y, i, at_least_one_changed)
          )
      in
      let (y, i) =
        if i = 0 then
          (0, 0)
        else
          let l = lines.(i) in (line_y l + line_height l, i+1)
      in
      self#update_gutter_widths ;
      let (y1, last_mod_line, at_least_one_changed) = iter y i false in
      (y, y1, last_mod_line, at_least_one_changed)

    method render_lines rend ~offset:(x,y) (rg:G.t) =
      let l1 = line_of_y lines rg.y in
      let l2 = line_of_y lines (rg.y + rg.h) in
      debug (fun m -> m "%s#render_lines offset=(%d,%d) rg=%a => l1=%d, l2=%d"
         self#me x y G.pp rg l1 l2);
      let regions =
        (* by now we use only a fake region between insert and
           selection cursors, using selection cursor props. *)
        match self#get_cursor self#selection_cursor with
        | None -> []
        | Some sc ->
            match self#get_cursor self#insert_cursor with
            | None -> []
            | Some ic ->
                match B.compare_line_offset sc.position ic.position with
                | 0 -> []
                | _ ->
                    let sel_props = Props.empty () in
                    Props.(set sel_props fg_color (self#get_p selection_fg_color));
                    Props.(set sel_props bg_color (self#get_p selection_bg_color));
                    Props.(set sel_props fill true);
                    Props.(set sel_props selected true);
                    [B.order_line_offsets ic.position sc.position, sel_props]
      in
      List.iter (fun ((lo1, lo2), reg_props) ->
         info (fun m -> m "region (%a, %a, %a)"
           B.pp_line_offset lo1 B.pp_line_offset lo2 Props.pp reg_props)
      ) regions;
      let active_line =
        match self#get_cursor self#insert_cursor with
        | None -> -1
        | Some c -> c.position.B.line
      in
      for i = l1 to l2 do
        let line = lines.(i) in
        let bg_color =
          if i = active_line && self#highlight_current_line then
            match self#opt_p Props.current_line_bg_color with
            | None -> self#get_p Props.bg_color
            | Some c -> c
          else
            self#get_p Props.bg_color
        in
        render_line rend ?wrap_char ~g_text:g_text ~offset:(x,y) rg bg_color regions i line
      done;
      (l1, l2, active_line)

    (* geom is relative to g_inner *)
    method private render_text rend ~offset:(x,y) geom =
      debug (fun m -> m "%s#render_text offset=%d,%d geom=%a g=%a g_text=%a"
         self#me x y G.pp geom G.pp g G.pp g_text);
      let (l1, l2, active_line) = self#render_lines rend ~offset:(x,y) geom in
      let off_x = g_text.x in
      let off_y = g_text.y in
      let offset = (x + off_x, y + off_y) in
      let rgtext = G.translate ~x:(-off_x) ~y:(-off_y) geom in
      if self#get_p show_cursors then
        B.Cursor_map.iter (fun id c ->
           self#render_cursor rend ~offset rgtext id c) cursors;
      (l1, l2, active_line)

    method private render_gutter_line rend ~offset:(x,y) rg ~xbase ~lnums ~markers
      ~padding_left ~padding_right ~padding_top
      ~bg_color ~fg_color font iline =
      let line = lines.(iline) in
      if lnums then
        (
         let y = y + g_text.y in
         render_gutter_line_bg rend ~offset:(x,y) rg ~xbase bg_color
           ~width:(padding_left + w_lnums + w_markers + padding_right)
           line ;
         let y = y + padding_top in
         render_gutter_line_number rend ~offset:(x+padding_left,y) rg ~xbase ~fg_color font
           ~width:w_lnums iline lines.(iline)
        );
      if markers then
        (

        );

    (* rg is the part of g_inner to render *)
    method private render_gutter rend ~offset rg (l1, l2, active_line) =
      let lnums = self#get_p show_line_numbers in
      let markers = self#get_p show_line_markers in
      if lnums || markers then
        (
         (* gutter is always render at the left of the visible rect *)
         match G.inter rg
           (G.translate ~x:(-g_inner.x) ~y:(-g_inner.y) self#visible_rect)
         with
         | None -> ()
         | Some vg ->
             debug (fun m -> m "%s#render_gutter rg=%a vg=%a" self#me G.pp rg G.pp vg);
             let gutter_props = self#get_p gutter_props in
             match gutter_font with
             | None -> ()
             | Some font ->
                 match G.inter vg rg with
                 | None -> ()
                 | Some rg ->
                     let padding = Props.(get gutter_props padding) in
                     let f = self#render_gutter_line rend ~offset rg ~xbase:vg.x
                       ~padding_left:padding.left ~padding_right:padding.right
                         ~padding_top:padding.top
                         ~lnums ~markers
                         ~bg_color:Props.(get gutter_props Props.bg_color)
                         ~fg_color:Props.(get gutter_props Props.fg_color)
                         font
                     in
                     for i = l1 to l2 do f i done
        )

    method! render_me ~layer rend ~offset:(x,y) rg =
      debug (fun m -> m "%s#render_me offset=%d,%d rg=%a g=%a g_inner=%a"
        self#me x y G.pp rg G.pp g G.pp g_inner);
      match G.inter rg (G.translate ~x:g.x ~y:g.y g_inner) with
      | None -> ()
      | Some rg ->
          debug (fun m -> m "%s#render inter=> rg=%a" self#me G.pp rg);
          let off_x = g.x + g_inner.x in
          let off_y = g.y + g_inner.y in
          let offset = (x + off_x, y + off_y) in
          let rg = G.translate ~x:(-off_x) ~y:(-off_y) rg in
          let lines_to_render = self#render_text rend ~offset rg in
          self#render_gutter rend ~offset rg lines_to_render

    method private init_with_buffer =
      let () =
        match self#register_to_buffer with
        | None -> ()
        | Some c ->
            insert_cursor <- Some c;
            let position = B.cursor_line_offset buffer c in
            let font = Props.get_font props in
            let cur = { position ; props ; font } in
            cursors <- B.Cursor_map.singleton c cur;
            let sc = B.dup_cursor ~widget:(self#id) buffer c in
            selection_cursor <- sc;
            match sc with
            | None -> ()
            | Some sc ->
                cursors <- B.Cursor_map.add sc
                  { cur with props = Props.empty() } cursors;
      in
      self#build_items ;
      self#child_need_render ~layer:(self#get_p Props.layer) g

    method private arrange_line line =
      arrange_line line (self#get_p wrap_mode) wrap_char g_text.w

    method private arrange_lines =
      [%debug "%s#arrange_lines g=%a g_text=%a" self#me G.pp g G.pp g_text];
      Array.iter
        (fun line -> arrange_line line (self#get_p wrap_mode) wrap_char g_text.w)
        lines;
      ignore(self#update_lines_y_from 0);
      self#need_resize

    method private build_items =
      let blines = B.lines buffer in
      let l = Array.mapi
        (fun pos _ -> mk_line props props_cache theme buffer pos)
        blines
      in
      lines <- l;
      self#arrange_lines;
      [%debug "items built (%d lines), need rendering" (Array.length lines)]

    method print_words =
      (*Inspect.Dot.dump_list_to_file "/tmp/textviewvalues.dot"
        ["char0", lines.(1).chars.(0) ;
          "char1", lines.(1).chars.(1) ;];*)
      [%debug "lines = %d words" (Obj.reachable_words (Obj.repr lines))];
      (*Log.warn (fun m ->
         let size = Array.fold_left
           (fun acc l -> acc + Array.length l.chars)
          0 lines
         in
         let t = Array.make size lines.(1).chars.(0) in
         let _ = Array.fold_left (fun pos l ->
           let len = Array.length l.chars in
           Array.blit l.chars 0 t pos len;
           pos+len)
           0 lines
         in
         m "chars: %d words" Obj.(reachable_words (repr t));
      );*)
      (*Inspect.Dot.dump_to_file "/tmp/textviewvalues.dot" t;*)
      [%debug "buffer: %d words" Obj.(reachable_words (repr buffer))];
      [%debug "lines+buffer: %d words" Obj.(reachable_words (repr (lines,buffer)))];
      [%debug "%s: %d words" self#me Obj.(reachable_words (repr self))];

    method private need_render_line i =
      match
        try Some lines.(i)
        with _ ->
            err (fun m -> m "%s#need_render_line i=%d: no such line"
               self#me i);
            None
      with
      | None -> ()
      | Some line ->
        (* render all g_inner at the given y and height *)
        let w = g_inner.w in
        let r = G.{ x = 0; y = line_y line ; w ; h = line_height line } in
        let r = G.translate ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y+g_text.y) r in
        self#need_render ~layer:(self#get_p Props.layer) r

    method private on_cursor_change cid ~prev ~now =
      info (fun m -> m "%s#on_cursor_change cid=%a ~prev:%a ~now:%a"
         self#me B.pp_cursor_id cid B.pp_line_offset prev B.pp_line_offset now);
      match self#get_cursor cid with
      | None -> ()
      | Some c ->
          let start = now.B.bol + now.B.offset in
          let () =
            (* do not change selection_cursor properties *)
            if cid = self#selection_cursor then
              ()
            else
              (
               let p =
                 match B.chars ~map_out:false buffer ~start ~size:1 with
                 | [] | _::_::_ -> props
                     (*debug (fun m -> m "%s#on_cursor_change: no char" self#me);*)
                 | [(_,tags)] ->
                     let props = compute_char_props
                       props props_cache theme tags
                     in
                     props
               in
               let font = Props.get_font p in
               c.font <- font ;
               c.props <- p
              )
          in
          c.position <- now ;
          (* render prev line only if it still exists *)
          if B.line_count buffer > prev.B.line then self#need_render_line prev.B.line;
          if now.B.line <> prev.B.line then
            self#need_render_line now.B.line;
          if self#is_insert_cursor cid then self#scroll_to_cursor ~c:cid ()

    method private cursor_rect c =
      let h = Font.font_height c.font in
      let ascent = Font.font_ascent c.font in
      let w = self#cursor_width in
      let line = lines.(c.position.B.line) in
      let (idline, dline) = dline_of_char line c.position.B.offset in
      debug (fun m -> m "%s#cursor_rect c=%a dline.range=%a" self#me pp_cursor c Rope.pp_range dline.range);
      let bound = dline.range.start + dline.range.size in
      let rec iter acc i =
        if i >= bound || i >= c.position.B.offset then
          acc
        else
          iter (acc+line.chars.(i).w) (i+1)
      in
      let x = iter 0 dline.range.start in
      let y = dline.y + dline.baseline - ascent in
      let r = G.{ x = x ; y ; w ; h } in
      debug (fun m -> m "%s#cursor_rect line=%d, offset=%d, rect=%a"
         self#me c.position.B.line c.position.B.offset G.pp r);
      r

    (* offset and rg are already relative to g_text *)
    method private render_cursor rend ~offset:(x,y) rg (cursor_id:B.cursor) c =
      let rect = self#cursor_rect c in
      debug (fun m -> m "%s#render_cursor ~offset=(%d,%d) rg=%a rect=%a"
        self#me x y G.pp rg G.pp rect);
      match G.inter rg rect with
      | None -> ()
      | Some rect ->
          let rect = G.translate ~x ~y rect in
          debug (fun m -> m "%s#render_cursor rect=%a" self#me G.pp rect);
          let col_prop =
            if self#is_insert_cursor cursor_id
            then Some Props.active_cursor_color
            else
              let sel_id = self#selection_cursor in
              if B.equal_cursor sel_id cursor_id
              then None
              else Some Props.cursor_color
          in
          match col_prop with
          | None -> ()
          | Some p -> Render.fill_rect rend (Some rect) (self#get_p p)

    method private register_to_buffer =
      B.register_widget buffer
        ~widget:self#as_widget
        ~on_change: self#on_buffer_change
        ~on_cursor_change: self#on_cursor_change
        ~on_tag_change: self#on_tag_change

(*    method need_render ~layer g =
      Log.warn (fun m -> m "%s#need_render g=%a" self#me G.pp g);
      super#need_render ~layer g
*)
    method private on_tag_change ranges =
      debug (fun m -> m "on_tag_change (%d ranges)" (List.length ranges));
      List.iter self#on_tag_change_line_range ranges ;
      let f_range (changed, last_updated_line) r =
        let line1 = max last_updated_line r.B.lstart.line in
        let line2 = r.lstop.line in
        let (y0, y1, last_updated_line, one_changed) =
          self#update_lines_y_from ~force_until:line2 (max 0 (line1 - 1))
        in
        self#need_render ~layer:(self#get_p Props.layer) g;
        (changed || one_changed, last_updated_line)
      in
      let (changed,_) = List.fold_left f_range (false, 0) ranges in
      if changed then self#need_resize

    method private on_tag_change_line_range range =
      let (line1, line2) = range.B.lstart.line, range.B.lstop.line in
      debug (fun m -> m "on_tag_change_line_range line1=%d, line2=%d" line1 line2);
      let rec iter i =
        if i > line2 then
          ()
        else
          (
           let start, stop =
             if line1 < i then
               if i < line2 then
                 (None, None)
               else
                 (None, Some range.B.lstop.offset)
             else
               if line1 = line2 then
                 (Some range.B.lstart.offset, Some range.B.lstop.offset)
               else
                 (Some range.B.lstart.offset, None)
           in
           let width_changed =
             update_line props props_cache theme buffer
               ?start ?stop lines.(i) i
           in
           if width_changed then self#arrange_line lines.(i);
           iter (i+1)
          )
      in
      iter line1

    method private on_buffer_insert range _str =
      let (line1, line2) = range.B.lstart.line, range.B.lstop.line in
      debug (fun m -> m "%s#on_buffer_insert line1=%d, line2=%d" self#me line1 line2);
      let () =
        if line1 = line2 then
          (
           let l = mk_line props props_cache theme buffer line1 in
           lines.(line1) <- l;
           self#arrange_line l
          )
        else
          (
           let blines = B.lines buffer in
           let nblines = Array.length blines in
           let newlines = Array.make nblines (lines.(0)) in
           Array.blit lines 0 newlines 0 line1 ;
           let rec iter i =
             if i > line2 then
               i
             else
               (
                let l = mk_line props props_cache theme buffer i in
                debug (fun m -> m "mk_line i=%d => line_y = %d, line_height = %d"
                   i (line_y l) (line_height l));
                newlines.(i) <- l;
                self#arrange_line l;
                iter (i+1)
               )
           in
           let next = iter line1 in
           debug (fun m -> m "on_buffer_insert nblines=%d, length(lines)=%d, next=%d"
              nblines (Array.length lines) next);
           if next < nblines then
             Array.blit lines (line1+1) newlines next (nblines-next);
           lines <- newlines
          )
      in
      let (_y0, _y1, _last_updated_line, one_changed) =
        self#update_lines_y_from (max 0 (line1 - 1))
      in
      self#need_render ~layer:(self#get_p Props.layer) g;
      if one_changed then self#need_resize

    method private on_buffer_delete range _str =
      let (line1, line2) = range.B.lstart.line, range.B.lstop.line in
      debug (fun m -> m "%s#on_buffer_delete line1=%d, line2=%d" self#me line1 line2);
      let old_nb_lines = Array.length lines in
      let () =
        if line1 = line2 then
          (
           let l = mk_line props props_cache theme buffer line1 in
           lines.(line1) <- l;
           self#arrange_line l
          )
        else
          (
           let blines = B.lines buffer in
           let nblines = Array.length blines in
           let newlines = Array.make nblines (lines.(0)) in
           Array.blit lines 0 newlines 0 line1 ;
           let l = mk_line props props_cache theme buffer line1 in
           newlines.(line1) <- l;
           self#arrange_line l;
           let next = line1 + 1 in
           debug(fun m -> m "on_buffer_delete: oldlines=%d, nblines=%d, line1=%d, line2=%d, next=%d"
             (Array.length lines) nblines line1 line2 next);
           if line2 + 1 < (Array.length lines) then
             Array.blit lines (line2+1) newlines next (Array.length lines - line2 - 1);
           lines <- newlines
          )
      in
      let (y0, y1, last_updated_line, one_changed) =
        self#update_lines_y_from (max 0 (line1 - 1))
      in
      self#need_render ~layer:(self#get_p Props.layer) g;
      (* we need to render if one_changed or there are less lines
         than before; else one_changed will be false if only last lines
         were deleted. *)
      if one_changed || old_nb_lines <> Array.length lines then
        self#need_resize

    method private on_buffer_change change =
      match change with
        | B.Del (r,str) -> self#on_buffer_delete r str
        | B.Ins (r,str) -> self#on_buffer_insert r str
        | B.Group _ -> ()

    method private tag_props t = Texttag.Theme.tag_props theme t

    method private readonly_insert =
      fun t1 t2 ->
        match t1, t2 with
        | None, None
        | None, Some _
        | Some _, None -> not self#editable
        | Some t1, Some t2 ->
            let p1 = Texttag.Theme.merge_tag_props theme t1 (Props.empty()) in
            let p2 = Texttag.Theme.merge_tag_props theme t2 (Props.empty()) in
            match Props.(opt p1 editable, opt p2 editable) with
            | Some b1, Some b2 -> not (b1 && b2)
            | _ -> not self#editable

    method private readonly_delete =
      fun t ->
        let p = Texttag.Theme.merge_tag_props theme t (Props.empty()) in
        match Props.(opt p editable) with
        | Some b -> not b
        | _ -> not self#editable

    (**/**)

    (** {2 Inserting and deleting} *)

    (** [v#insert_at offset string] inserts [string] at [offset].
       Options arguments:
       {ul
        {- [honor_readonly] specifies whether insertion is conditioned by
           the {!Props.val-editable} property of tags. Default is [false]. It
           is called with [true] to insert the text the user types in.}
        {- [tags] specifies tags to associate to inserted characters.}
       }
    *)
    method insert_at ?(honor_readonly=false) ?tags at str =
      let readonly = if honor_readonly then Some self#readonly_insert else None in
      B.insert buffer ?readonly ?tags at str

    (** Same as {!class-textview.insert_at} but inserts at the position of the insert
      cursor or the position of a cursor given with argument [c]. *)
    method insert ?(honor_readonly=false) ?tags ?c str =
      let c =
        match c with
        | None -> self#insert_cursor
        | Some c -> c
      in
      let readonly = if honor_readonly then Some self#readonly_insert else None in
      B.insert_at_cursor buffer c ?readonly ?tags str

    (** [v#delete ()] delete contents of buffer.
     Optional arguments:
      {ul
       {- [start]: the start of range to delete (default is [0]).}
       {- [size]: the size of range to delete. Default is buffer size - [start]. }
       {- [honor_readonly] specifies whether deletion is conditioned by
           the {!Props.val-editable} property of tags. Default is [false]. It
           is called with [true] to delete text from a user action.}
      }
    *)
    method delete ?(honor_readonly=false) ?start ?size () =
      let readonly = if honor_readonly then Some self#readonly_delete else None in
      B.delete ?readonly ?start ?size buffer

    (** [v#delete_backward n] deletes [n] characters backward the insert cursor.
      Optional arguments:
      {ul
       {- [c] to indicate another cursor to delete backward from.}
       {- [honor_readonly] (default is [false]): same as in {!class-textview.delete}.}
      }
    *)
    method delete_backward ?(honor_readonly=false) ?(c=self#insert_cursor) n =
      let readonly = if honor_readonly then Some self#readonly_delete else None in
      let o = B.cursor_offset buffer c in
      let start = o - n in
      let (start, size) =
        if start >= 0
        then start, n
        else (0, n + start)
      in
      B.delete buffer ?readonly ~start ~size

    (** Same as {!class-textview.delete_backward} but deletes forward from cursor. *)
    method delete_forward ?(honor_readonly=false) ?(c=self#insert_cursor) size =
      let readonly = if honor_readonly then Some self#readonly_delete else None in
      let start = B.cursor_offset buffer c in
      B.delete buffer ?readonly ~start ~size

    (** [v#replace_selection str] replaces the selected range, if any, by
     [str], in a single history action.
     If no range is selected, just insert [str] at insert cursor.
     Optional argument [honor_readonly] is passed to {!class-textview.delete}
     and {!class-textview.insert} methods. *)
    method replace_selection ?honor_readonly str =
      match self#selection_range with
      | None -> self#insert ?honor_readonly str
      | Some { start ; size } ->
          B.begin_action buffer;
          let _ = self#delete ?honor_readonly ~start ~size () in
          self#insert ?honor_readonly str;
          B.end_action buffer

    (** [v#cut ()] cut the selected range, if any, and copies it to clipboard.
       Optional argument [honor_readonly] is passed to {!class-textview.delete}.
       Returns the deleted string, if any.
    *)
    method cut ?honor_readonly () =
      match self#selection with
      | "" -> None
      | str ->
          let>() = Sdl.set_clipboard_text str in
          info (fun m -> m "cut %S" str);
          self#replace_selection ?honor_readonly "";
          Some str

     (** [v#paste ()] calls {!class-textview.replace_selection}
       with the clipboard text, if any.
       Optional argument [honor_readonly] is passed to
       {!class-textview.replace_selection}.
    *)
    method paste ?honor_readonly () =
      match Selection.get () with
      | Some str ->
          self#replace_selection ?honor_readonly str
      | None  ->
          if Sdl.has_clipboard_text () then
            let> str = Sdl.get_clipboard_text () in
            self#replace_selection ?honor_readonly str
          else
            ()

    (** [v#copy] copies the selected text, if any, to clipbloard. *)
    method copy =
      match self#selection with
      | "" -> ()
      | str -> let>() = Sdl.set_clipboard_text str in ()

    (**/**)

    method transpose_chars ?(honor_readonly:bool option) ?(c=self#insert_cursor) () =
      Log.warn (fun m -> m "textview#transpose_chars not implemented yet")
    method transpose_lines ?(honor_readonly:bool option) ?(c=self#insert_cursor) () =
      Log.warn (fun m -> m "textview#transpose_lines not implemented yet")
    method transpose_words ?(honor_readonly:bool option) ?(c=self#insert_cursor) () =
      Log.warn (fun m -> m "textview#transpose_words not implemented yet")

    method private ins_or_sel_cursor =
      if Key.shift_pressed () then
        self#selection_cursor
      else
        self#insert_cursor

    method on_sdl_event pos ev =
      match Sdl.Event.(enum (get ev typ)) with
      | `Text_input ->
          let str = Sdl.Event.(get ev text_input_text) in
          (*info (fun m -> m "%s text_input %S" self#me str);*)
          self#replace_selection ~honor_readonly:true str ;
          true
      | `Text_editing ->
          (*Sdl.set_text_input_rect (Some (G.to_rect g));*)
          false
      | _ ->
          match state_machine.f pos ev with
          | false -> super#on_sdl_event pos ev
          | true -> true

    method! on_mouse_leave =
      (match state_machine.state () with
       | `Selecting -> state_machine.set_state `Base
       | _ -> ());
       super#on_mouse_leave

    method on_file_dropped ev =
      self#replace_selection ~honor_readonly:true ev.text;
      true
    method on_text_dropped ev = self#on_file_dropped ev

    method state_on_event state pos ev =
      match state, pos, Sdl.Event.(enum (get ev typ)) with
      | `Base, Some (x,y), `Mouse_button_down ->
          let button = Sdl.Event.(get ev mouse_button_button) in
          if button = 1 then
            let (line,dline,ichar) = self#line_char_of_coords ~x ~y in
            let char = dline.range.start + ichar in
            let _ = self#move_cursor ~line ~char () in
            Some (`Selecting, false)
          else
          None
      | `Selecting, _, `Mouse_button_up ->
          let button = Sdl.Event.(get ev mouse_button_button) in
          if button = 1 then
            Some (`Base, false)
          else
            None
      | `Selecting, Some (x,y), `Mouse_motion ->
          if G.inside ~x ~y self#visible_rect then
            let (line,dline,ichar) = self#line_char_of_coords ~x ~y in
            let char = dline.range.start + ichar in
            let _ = self#move_cursor ~line ~char ~c:self#selection_cursor () in
            None
          else
            Some (`Base, false)
      | (`Base|`Selecting), _, _ -> None

    method on_key_down pos ev key mods =
      let ret =
        match Sdl.Event.(get ev keyboard_keycode) with
        | k when k = Sdl.K.home ->
            let _ = self#move_to_line_start () in
            true
        | k when k = Sdl.K.kend ->
            let _ = self#move_to_line_end () in
            true
        | k when k = Sdl.K.up ->
            let _ = self#dline_backward 1 in
            true
        | k when k = Sdl.K.down ->
            let _ = self#dline_forward 1 in
            true
        | k when k = Sdl.K.pageup ->
            let _ = self#page_backward () in
            true
        | k when k = Sdl.K.pagedown ->
            let _ = self#page_forward () in
            true
        | k when k = Sdl.K.left ->
            let _ =
(*              if Key.ctrl_pressed () then
                self#backward_to_word_start ()
              else*)
                self#char_backward 1
            in
            true
        | k when k = Sdl.K.right ->
            let _ =
(*              if Key.ctrl_pressed () then
                self#forward_to_word_end ()
              else*)
                self#char_forward 1
            in
            true
        | k when k = Sdl.K.return ->
            self#replace_selection ~honor_readonly:true "\n" ;
            true
        | k when k = Sdl.K.backspace ->
            self#delete_backward ~honor_readonly:true 1 ;
            true
        | k when k = Sdl.K.delete ->
            (match self#selection_range with
             | None ->
                 let _ = self#delete_forward ~honor_readonly:true 1 in
                 let _ = self#sel_to_ins_cursor in
                 true
             | Some _ ->
                 let _ = self#replace_selection ~honor_readonly:true "" in
                 true
            )
        | _ -> super#on_key_down pos ev key mods
      in
      ret

    method on_tagtheme_changed ~prev ~now =
      self#apply_theme ;
      self#need_render ~layer:(self#get_p Props.layer) g

    val mutable formatter_tags = []
    method formatter_tags = formatter_tags
    method set_formatter_tags l = formatter_tags <- l
    method formatter =
      let out s start len =
        let s = String.sub s start len in
        self#insert ~tags:self#formatter_tags s
      in
      Format.make_formatter out (fun () -> ())

    method check =
      Log.warn (fun m -> m "%s: Checking buffer and cursors" self#me);
      B.check buffer ;
      let check_cursor id c =
        let p = c.position in
        let lo = B.cursor_line_offset buffer id in
        match B.compare_line_offset p lo with
        | 0 -> ()
        | _ ->
           Log.err (fun m -> m "%s: cursor %a has bad position in view: %a instead of %a"
             self#me B.pp_cursor_id id B.pp_line_offset p B.pp_line_offset lo)
      in
      B.Cursor_map.iter check_cursor cursors

    method pp_cursor ppf c =
      match self#get_cursor c with
      | None -> Format.pp_print_string ppf "No such cursor"
      | Some c -> pp_cursor ppf c

    (**/**)

    (** {2 History} *)

    (** [v#in_action f] calls [f()] between {!Textbuffer.begin_action}
     and {!Textbuffer.end_action}. The result of [f()] is returned.
     If [f()] raises an exception, the action is ended and the exception
     if reraised. *)
    method in_action : 'a. (unit -> 'a) -> 'a = fun f ->
      B.begin_action buffer;
      try let res = f () in B.end_action buffer; res
      with e -> B.end_action buffer; raise e

    (** Reset buffer history. *)
    method reset_history = B.reset_history buffer

    (** Undo last action. *)
    method undo = B.undo buffer

    (** Redo last undo. *)
    method redo = B.redo buffer

    initializer
      state_machine <- Misc.mk_state_machine `Base self#state_on_event ;
      let _ = self#connect (Object.Prop_changed Texttag.Theme.prop)
        self#on_tagtheme_changed
      in
      self#update_wrap_char ;
      self#init_with_buffer ;
(*         let ks_copy = Key.keystate_of_string "C-c" in
         let ks_cut = Key.keystate_of_string "C-x" in
         let ks_paste = Key.keystate_of_string "C-v" in
         let _ = self#connect Widget.Key_pressed
           (fun ev ->
              if Key.match_keys ks_copy ev.Widget.key ev.Widget.mods then
                let%lwt _ = self#copy in Lwt.return_true
              else
                if Key.match_keys ks_cut ev.Widget.key ev.Widget.mods then
                  let%lwt _ = self#cut in Lwt.return_true
                else
                  if Key.match_keys ks_paste ev.Widget.key ev.Widget.mods then
                    let%lwt _ = self#paste in Lwt.return_true
                  else
                    Lwt.return_false
           )
         in
  *)

  end


(** Convenient function to create a {!class-textview}.
  An existing buffer to use can be specified with optional argument
  [buffer].
  Properties
   {!val-highlight_current_line}, {!val-show_cursors}, {!val-show_line_markers},
   {!val-show_line_numbers}, {!val-wrap_mode}, {{!Texttag.Theme.val-prop}[tagtheme]}
   and {!Props.val-editable} can be specified with the corresponding optional
  arguments.
  [handle_lang_tags] indicates whether to add {!Texttag.Lang.tags} as
  {{!class-textview.section-handled_tags}handled tags} (default is [false].
  See {!Widget.section-widget_arguments} for other arguments. *)
let textview ?classes ?name ?props ?wdata ?buffer
  ?highlight_current_line ?show_cursors ?show_line_numbers
  ?show_line_markers ?wrap_mode ?editable ?tagtheme
    ?(handle_lang_tags=false) ?pack () =
  let w = new textview ?classes ?name ?props ?wdata ?buffer () in
  Option.iter w#set_show_cursors show_cursors ;
  Option.iter w#set_wrap_mode wrap_mode ;
  Option.iter w#set_editable editable ;
  Option.iter w#set_highlight_current_line highlight_current_line ;
  Option.iter w#set_show_line_numbers show_line_numbers ;
  Option.iter w#set_show_line_markers show_line_markers ;
  if handle_lang_tags then List.iter w#add_handled_tag Texttag.Lang.tags;
  Option.iter w#set_tagtheme tagtheme ;
  Widget.may_pack ?pack w#coerce ;
  w

(** [set_default_key_bindings textview] add some key bindings to
  [textview]. Optional argument [display_state] is a function to
  call to display the state of keyboard hitstate tree.
  The keybindings added are:
  {ul
   {- [C-e]: move cursor to line end,}
   {- [S/C-a]: move cursor to line start,}
   {- [S/C-right]: move cursor to next word end,}
   {- [S/C-left]: move cursor to previous word start,}
   {- [C-c]: copy selection to clipboard,}
   {- [C-x]: cut selection to clipboard,}
   {- [C-v]: paste clipboard.}
  }
*)
let set_default_key_bindings ?display_state (tv : textview) =
  let kb = [
      [`String "C-e"], (fun () -> ignore(tv#move_to_line_end ()) ) ;
      [`String "S/C-a"], (fun () -> ignore(tv#move_to_line_start ()) ) ;
      [`String "S/C-right"], (fun () -> ignore(tv#forward_to_word_end ()) ) ;
      [`String "S/C-left"], (fun () -> ignore(tv#backward_to_word_start ()) ) ;
      [`String "C-c"], (fun () -> tv#copy) ;
      [`String "C-x"], (fun () -> ignore(tv#cut ~honor_readonly:true ()) ) ;
      [`String "C-v"], (fun () -> tv#paste ~honor_readonly:true ()) ;
    ]
  in
  let kb = List.map (fun (b,f) ->
       (Key.keystate_list_ocf_wrapper.from_json (`List b), f)) kb
  in
  let trees = Wkey.trees_of_list kb in
  Wkey.set_handler_trees (fun () -> trees) ?display_state tv#as_widget