Source file clist.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"]

let show_headers = Props.bool_prop ~inherited:false ~default:true
  ~after:[Props.Resize] "show_headers"
let css_show_headers = Theme.bool_prop show_headers

let title = Props.string_prop ~inherited:false ~after:[Props.Resize] "title"
let header_props = Props.props_prop ~inherited:false ~default:(Props.create())
  ~after:[Props.Resize] "header_props"

let line_separator_width = Props.int_prop ~inherited:false ~default:0
  ~after:[Props.Resize] "line_separator_width"
let css_line_separator_width = Theme.int_prop line_separator_width

let line_separator_color = Props.color_prop ~inherited:false ~default:Color.grey
  ~after:[Props.Render] "line_separator_color"
let css_line_separator_color = Theme.color_prop line_separator_color

let column_separator_width = Props.int_prop ~inherited:false ~default:0
  ~after:[Props.Resize] "column_separator_width"
let css_column_separator_width = Theme.int_prop column_separator_width

let column_separator_color = Props.color_prop ~inherited:false ~default:Color.grey
  ~after:[Props.Render] "column_separator_color"
let css_column_separator_color = Theme.color_prop column_separator_color

type _ Events.ev +=
| Row_removed : ((int * 'a) -> unit) Events.ev
| Data_set : ('a list -> unit) Events.ev
| Row_inserted : ((int * 'a) -> unit) Events.ev
| Row_selected : ((int * 'a) -> unit) Events.ev
| Row_unselected : ((int * 'a) -> unit) Events.ev
| Row_updated : ((int * 'a * 'a) -> unit) Events.ev

(** Row height: A negative value means each row has its own height.
  0 means that rows all have the same height, which is the max height
  of rows. A positive value is used to force all rows heights. *)
let row_height = Props.int_prop ~default:0 ~after:[Props.Resize] "row_height"

let array_find_opt =
  let rec iter f t len i =
    if i >= len then None
    else
      let x = t.(i) in
      if f x then Some (i, x) else iter f t len (i+1)
  in
  fun f t ->
    let len = Array.length t in
    iter f t len 0

class type ['a] cell =
  object
    inherit Widget.widget
    method contents : 'a -> unit
    method set_contents : 'a -> unit
    method kind : string
  end

class virtual ['a] cell_ ?classes ?name ?props () =
  object
    method virtual contents : 'a -> unit
    method virtual set_contents : 'a -> unit
    method kind = "cell"
  end

class ['a] label_cell(* : ?class_:string -> ?name:string -> ?props:Props.t ->
  to_data:('a -> string -> Props.t -> unit) ->
  of_data:('a -> string * Props.t option) -> 'a -> ['a] cell*) =
    fun ?classes ?name ?props ~to_data ~of_data () ->
    object(self)
      inherit ['a] cell_ ?classes ?name ?props () as dsuper
      inherit Text.label ?classes ?name ?props () as super
      method kind = dsuper#kind
      method contents (d:'a) = to_data d super#text self#props
      method set_contents d =
        let (text, p) = of_data d in
        Option.iter super#set_props p ;
        super#set_text text;

(*      method! set_geometry geom =
        Log.warn (fun m -> m "%s#set_geometry %a" self#me G.pp geom);
        super#set_geometry geom
*)
      initializer
        self#add_class super#kind
    end

let string_cell ?classes ?name ?props ?(focusable=true) (of_data:'a -> string * Props.t option)
  ?(to_data=fun _ _ _ -> ()) () =
  let o = new label_cell ?classes ?name ?props ~to_data ~of_data () in
  o#set_focusable focusable ;
  o#set_can_focus focusable ;
  ( o :> 'a cell)

let int_cell ?classes ?name ?props ?(focusable=true)
  ?(to_data=fun _ _ _ -> ()) of_data () =
  let of_data d = let (n, p) = of_data d in (string_of_int n, p) in
  let to_data d s p = to_data d (int_of_string s) p in
  let o = new label_cell ?classes ?name ?props ~to_data ~of_data () in
  o#set_focusable focusable ;
  o#set_can_focus focusable ;
  ( o :> 'a cell)

class ['a] text_cell =
    fun ?classes ?name ?props ~to_data ~of_data () ->
    object(self)
      inherit ['a] cell_ ?classes ?name ?props () as dsuper
      inherit Textview.textview ?classes ?name ?props () as super
      method kind = dsuper#kind
      method contents (d:'a) = to_data d super#text self#props
      method set_contents d =
        let (text, p) = of_data d in
        Option.iter super#set_props p ;
        ignore(self#delete ());
        self#insert text
      initializer
        self#add_class super#kind
    end

let text_cell ?classes ?name ?props
  ?(to_data=fun _ (_:?start:int -> ?size:int -> ?stop:int -> unit -> string) _ -> ())
    of_data () =
  let o = new text_cell ?classes ?name ?props ~to_data ~of_data () in
  ( o :> 'a cell)

let cell_of_y =
  let rec iter cells y left right =
    [%debug "Clist.cell_of_y: y=%d, left=%d, right=%d" y left right];
    if left > right then
      None
    else
      if left = right then
        Some left
      else
        let i = (left + right) / 2 in
        let cell = cells.(i) in
        let g_cell = cell#geometry in
        if g_cell.G.y > y then
          iter cells y left i
        else
          if g_cell.y + g_cell.h < y then
            iter cells y (i+1) right
          else
            Some i
  in
  fun cells y ->
(*    Log.warn (fun m -> m "cell_of_y y=%d" y);*)
    let c = iter cells y 0 (Array.length cells - 1) in
(*    Log.warn (fun m -> m "cell_of_y => c=%d" (Option.value ~default:(-1) c));*)
    c

let array_remove t pos =
  let len = Array.length t in
  assert ( pos >= 0 && pos < len);
  if len = 1 then
    [| |]
  else
    if pos = 0 then
      Array.sub t 1 (len-1)
    else
      if pos = len - 1 then
        Array.sub t 0 (len-1)
      else
        (
         let a = Array.make (len-1) t.(0) in
         Array.blit t 0 a 0 pos;
         Array.blit t (pos+1) a pos (len-pos-1);
         a
        )

class ['a] column_ ?classes ?name ?props ?wdata (mk_cell : unit -> 'a cell) =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    method kind = "column"
    val mutable header = (None : Widget.widget option)
    val mutable cells : 'a cell array = [| |]
    val mutable sort_fun = (None : ('a -> 'a -> int) option)
    method sort_fun = sort_fun
    method set_sort_fun f =
      sort_fun <- f;
      self#update_header

    method! private do_apply_theme ~root ~parent parent_path rules =
      super#do_apply_theme ~root ~parent parent_path rules;
      let path = self#css_path ~parent_path () in
      Option.iter (fun w -> w#do_apply_theme ~root ~parent:theme_props path rules) header;
      Array.iter (fun c -> c#do_apply_theme ~root ~parent:theme_props path rules) cells

    val mutable on_header_activated = None
    method set_on_header_activated f = on_header_activated <- f

    method wtree =
      let cells = List.map (fun c -> c#coerce) (Array.to_list cells) in
      let l = match header with
        | None -> cells
        | Some h -> h :: cells
      in
      Widget.N (self#coerce, List.map (fun c -> c#wtree) l)

    method header = header

    method show_headers = self#get_p show_headers
    method set_show_headers = self#set_p show_headers

    method header_props = self#get_p header_props
    method set_header_props = self#set_p header_props

    method! private themable_props = header_props :: super#themable_props

    method width = self#opt_p Props.width
    method set_width = function
    | None -> Props.set_opt props Props.width None
    | Some w -> self#set_p Props.width w

    method title = self#opt_p title
    method set_title = self#set_p title

    method private update_header =
      match self#show_headers, header with
      | false, None -> ()
      | false, Some w -> w#destroy; header <- None
      | true, Some w ->
          w#destroy; header <- None;
          self#update_header
      | true, None ->
          let text = Option.value ~default:"" self#title in
          let w =
            match sort_fun with
            | None -> (Text.label ~props:self#header_props ~text ())#coerce
            | Some _ ->
                let (b,label) = Button.text_button ~props:self#header_props ~text () in
                ignore(b#connect Widget.Activated
                 (fun () -> Option.iter (fun f -> f ()) on_header_activated));
                b#coerce
          in
          w#add_class (Printf.sprintf "%s-header" self#kind);
          w#set_parent ?with_rend:with_renderer (Some self#coerce) ;
          [%debug "%s#props: %a" w#me Props.pp w#props];
          header <- Some w

    method clear =
      Array.iter (fun cell -> cell#destroy) cells;
      cells <- [| |];
      min_width <- None ;
      min_height <- None

    method insert ?pos data =
      (*Log.warn(fun m -> m "%s#insert ?pos=%s" self#me
        (match pos with None -> "None" | Some i -> string_of_int i));
      *)
      let cell = mk_cell () in
      cell#set_parent ?with_rend:with_renderer (Some self#coerce) ;
      cell#set_contents data ;
      let len = Array.length cells in
      let pos =
        match pos with
        | Some 0 ->
            cells <- Array.append [| cell |] cells ;
            0
        | Some p when p < len ->
            let a = Array.make (len+1) cell in
            Array.blit cells 0 a 0 p;
            Array.blit cells (p+1) a (p+1) (len - p);
            cells <- a;
            p
        | _ ->
            cells <- Array.append cells [| cell |] ;
            len
      in
      min_width <- None ;
      min_height <- None ;
      pos

    method remove pos =
      let t = array_remove cells pos in
      cells.(pos)#destroy ;
      cells <- t;
      min_width <- None ;
      min_height <- None

    method set_row row d =
      cells.(row)#set_contents d;
      min_width <- None ;
      min_height <- None

    method set_list l =
      let old_ignore_resize = ignore_need_resize in
      self#ignore_need_resize ;
      self#clear ;
      let t = Array.of_list l in
      cells <- Array.map (fun _ -> mk_cell ()) t;
      Array.iter (fun c ->  c#set_parent ?with_rend:with_renderer (Some self#coerce)) cells;
      Array.iter2 (fun c d -> c#set_contents d) cells t;
      if old_ignore_resize then self#handle_need_resize

    method cell i : 'a cell = cells.(i)

    method! private min_width_ =
      let w =
        match self#width with
        | Some w when w > 0 -> w
        | _ ->
            let hd_width = match header with
              | None -> 0
              | Some h -> h#min_width
            in
            Array.fold_left (fun acc cell -> max acc cell#min_width)
              hd_width cells
      in
      [%debug "%s#min_width = %d (%d cells)" self#me w (Array.length cells)];
      super#min_width_ + w

    method! private min_height_ =
      Log.warn (fun m -> m "%s#min_height should not be used" self#me);
      super#min_height_

    method max_width = Some self#min_width
    method max_height = None

    method! set_geometry geom =
      [%debug "%s#set_geometry %a" self#me G.pp geom];
      super#set_geometry geom ;
      let w = g_inner.w in
      Option.iter (fun h ->
         let g = h#geometry in
         h#set_geometry { g with G.w })
         header;
      Array.iter
        (fun c ->
           let gc = c#geometry in
           if gc.G.w <> w then
             c#set_geometry { gc with G.w })
        cells

    method cell_of_y y =
      [%debug "%s: cell_of_y y=%d" self#me y];
      if y < 0 then None
      else
        match header with
        | Some w ->
            let wg = w#geometry in
            if wg.y + wg.h > y then None else cell_of_y cells y
        | None ->  cell_of_y cells y

    method private render_cells ~layer rend ~offset rg =
      (*Log.warn (fun m -> m "%s#render_cells rg=%a" self#me G.pp rg);*)
      let len = Array.length cells in
      let rec iter i =
        if i < len then
          (
           let cell = cells.(i) in
           cell#render ~layer rend ~offset rg ;
           let g_cell = cell#geometry in
           (*Log.warn (fun m -> m "cells.(%d)#geometry = %a" i G.pp g_cell);*)
           if g_cell.y + g_cell.h < rg.y + rg.h then
             iter (i+1)
          )
      in
      let start_y =
        match header with
        | None -> rg.y
        | Some w ->
            let wg = w#geometry in
            let y = wg.y + wg.h in
            (*Log.warn (fun m -> m "header geometry=%a, rg=%a" G.pp wg G.pp rg);*)
            min (rg.y + rg.h) (max y rg.y)
      in
      match self#cell_of_y start_y with
      | None -> ()
      | Some i -> iter i

    method render_me ~layer rend ~offset:(x,y) rg =
      (*Log.warn (fun m -> m "%s#render_me 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
      Option.iter (fun h -> h#render ~layer rend ~offset rg) header ;
      self#render_cells ~layer rend ~offset rg

    method on_sdl_event_down ~oldpos pos e =
      [%debug "%s#on_sdl_event_down" self#me];
      if self#sensitive then
        match
          let f (x,y) = (x - g.x - g_inner.x , y - g.y - g_inner.y) in
          let oldpos = Option.map f oldpos in
          let pos = Option.map f pos in
          match Sdl.Event.(enum (get e typ)) with
          | `Key_down | `Key_up | `Text_input | `Text_editing ->
              (
               let pred w = (w:>Widget.widget)#get_p Props.is_focus in
               match header with
               | Some w when pred w -> w#on_sdl_event_down ~oldpos pos e
               | _ ->
                   match array_find_opt pred cells with
                   | None -> false
                   | Some (_,w) -> w#on_sdl_event_down ~oldpos pos e
              )
          | _ ->
              let on_w w =
                let gw = w#geometry in
                if (match oldpos with
                   | Some (x,y) -> G.inside ~x ~y gw
                   | None -> false
                  ) ||
                  match pos with
                  | Some (x,y) -> G.inside ~x ~y gw
                  | None -> true
                then
                  (
                   (*Log.warn (fun m -> m "%s#on_sdl_event_down: propagating event to %s"
                      self#me w#me);*)
                   w#on_sdl_event_down ~oldpos pos e
                  )
                else
                  false
              in
              let b = match header with
                | None -> false
                | Some w -> on_w w
              in
              Array.fold_left
                (fun acc w -> on_w w || acc)
                b cells
        with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method! child_focus_next _ =
      match parent with
      | None -> false
      | Some p -> p#child_focus_next self#coerce
    method! child_focus_prev _ =
      match parent with
      | None -> false
      | Some p -> p#child_focus_prev self#coerce

    method! focus_next =
      Log.err (fun m -> m "%s#focus_next should not be called" self#me);
      false
    method! focus_prev =
      Log.err (fun m -> m "%s#focus_prev should not be called" self#me);
      false

    method focused_child =
      match header with
      | Some w when w#is_focus -> Some (`Header w)
      | _ ->
          Option.map (fun (i,w) -> `Cell (i, w#as_widget))
            (array_find_opt
             (fun c -> (c:>Widget.widget)#get_p Props.is_focus)
               cells)
    method! focused_widget =
      if self#is_focus then
        match self#focused_child with
        | None -> Some self#coerce
        | Some (`Header w | `Cell (_,w)) -> w#focused_widget
      else
        None
    method! release_focus =
      match
        match self#focused_child with
        | None -> true
        | Some (`Header w | `Cell (_,w)) -> w#release_focus
      with
      | true ->
          self#set_p Props.is_focus false ;
          self#set_p Props.has_focus false ;
          true
      | _ -> false

    method! get_focus =
      match super#get_focus with
      | None -> None
      | Some has_focus ->
          Array.iter (fun w -> (w:>Widget.widget)#set_p Props.is_focus false) cells;
          Some has_focus

    method set_has_focus b =
      match super#set_has_focus b with
      | true -> true
      | false ->
          match self#focused_child with
          | None -> false
          | Some (`Header w | `Cell (_,w)) -> w#set_has_focus b

    method grab_focus ?(last=false) () =
      [%debug "%s#grab_focus ~last:%b" self#me last];
      if self#visible then
        match self#get_p Props.can_focus with
        | false -> false
        | true ->
            let rec iter len i =
              if i < 0 || i >= len then
                false
              else
                let c = cells.(i) in
                match c#visible, c#get_p Props.can_focus with
                | true, true ->
                    (match c#grab_focus ~last () with
                     | false -> iter len (if last then i-1 else i+1)
                     | true -> true)
                | _ -> iter len (if last then i-1 else i+1)
            in
            let len = Array.length cells in
            iter len (if last then len - 1 else 0)
      else
        false
    initializer
      self#update_header;
      ignore(self#connect (Object.Prop_changed show_headers)
        (fun ~prev ~now -> self#update_header));
      ignore(self#connect (Object.Prop_changed title)
        (fun ~prev ~now -> self#update_header))
  end

type 'a column = 'a column_
let column ?classes ?name ?props ?wdata ?header_props ?sort_fun ?title mk_cell =
  let c = new column_ ?classes ?name ?props ?wdata mk_cell in
  Option.iter c#set_title title ;
  Option.iter c#set_header_props header_props ;
  c#set_sort_fun sort_fun ;
  c

type sort_order = Ascending | Descending
type sorted = int * sort_order
module TSorted =
  struct
    type t = sorted
    let compare = Stdlib.compare
    let wrapper =
      let o_wrapper =
        let to_json ?with_doc = function
        | Ascending -> `Int 1
        | Descending -> `Int (-1)
        in
        let from_json ?def = function
        | `Int n -> if n >= 0 then Ascending else Descending
        | json -> Ocf.invalid_value json
        in
        Ocf.Wrapper.make to_json from_json
      in
      Some (Ocf.Wrapper.(pair int o_wrapper))
    let transition = None
  end
module PSorted = Props.Add_prop_type(TSorted)
let sorted = PSorted.mk_prop ~after:[Props.Render]
  ~inherited:false "sorted"

class ['a] clist ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    method kind = "clist"
    val mutable columns : 'a column array = [| |]
    val mutable data : 'a array = [| |]
    val mutable selection = Misc.ISet.empty
    method sorted = self#opt_p sorted
    method set_sorted = self#set_p sorted

    method! show =
      let v = self#visible_rect in
      [%debug "%s#show: visible_rect=%a" self#me G.pp v];
      self#show_rect v

    method data = data

    method wtree = Widget.N
      (self#coerce,
       List.map (fun c -> c#wtree) (Array.to_list columns))

    method! private do_apply_theme ~root ~parent parent_path rules =
      super#do_apply_theme ~root ~parent parent_path rules;
      let path = self#css_path ~parent_path () in
      Array.iter (fun c -> c#do_apply_theme ~root ~parent:theme_props path rules) columns

    method selection_mode = self#get_p Props.selection_mode
    method set_selection_mode = self#set_p Props.selection_mode

    method line_separator_width = self#get_p line_separator_width
    method set_line_separator_width = self#set_p line_separator_width
    method line_separator_color = self#get_p line_separator_color
    method set_line_separator_color = self#set_p line_separator_color
    method column_separator_width = self#get_p column_separator_width
    method set_column_separator_width = self#set_p column_separator_width
    method column_separator_color = self#get_p column_separator_color
    method set_column_separator_color = self#set_p column_separator_color

    method selection = Misc.ISet.elements selection
    method selection_data = List.map (Array.get data) self#selection

    method private valid_row ?(tip="") row =
      let len = Array.length data in
      if row < 0 || row >= len then
        (
         Log.err (fun m -> m "%s%s: invalid row %d (data has length %d)"
            self#me tip row len);
         false
        )
      else
        true

    method show_headers = self#get_p show_headers
    method set_show_headers ?delay ?propagate b =
      self#set_p show_headers ?delay ?propagate b;
      Array.iter (fun (col:'a column) -> col#set_show_headers b) columns

    method row_height = self#get_p row_height
    method set_row_height = self#set_p row_height

    method private row_of_y y =
      if Array.length columns <= 0 then
        None
      else
        let y = y - g_inner.y - g.y in
        columns.(0)#cell_of_y y

    method private col_of_x x =
      let len = Array.length columns in
      let x = x - g_inner.x - g.x in
      let rec iter i =
        if i >= len then
          None
        else
          let g = columns.(i)#geometry in
          if g.x <= x && x <= g.x + g.w then
            Some i
          else
            iter (i+1)
      in
      iter 0

    method private set_columns_geometry =
      [%debug "%s#set_columns_geometry" self#me];
      let len = Array.length columns in
      let rec iter i x =
        if i >= len then
          ()
        else
          let c = columns.(i) in
          let w = c#min_width in
          let w =
            if i = len - 1 (* last column *) then
              max w g_inner.w - x
            else
              w
          in
          let geom = { G.x = x ; y = 0 ; w ; h = g_inner.h } in
          c#set_geometry geom;
          iter (i+1) (x+w+self#column_separator_width)
      in
      iter 0 0

    method private on_header_activated c =
      match self#column_index c with
      | None -> Log.warn (fun m -> m "%s: no column found" self#me);
      | Some i ->
          match c#sort_fun, self#sorted with
          | None, _ -> Log.warn (fun m -> m "%s#on_header_activated no sort fun" self#me)
          | Some _, None -> self#set_sorted (i, Ascending)
          | Some _, Some (n,o) ->
              let o = if n <> i || o = Descending then Ascending else Descending in
              self#set_sorted (i, o)

    method add_column ?pos (c:'a column) =
      [%debug "%s#add_column %s (len(data)=%d)"
         self#me c#me (Array.length data)];
      c#set_show_headers (self#show_headers);
      c#set_parent ?with_rend:with_renderer (Some self#coerce) ;
      let len = Array.length columns in
      let pos =
        match pos with
        | Some 0 ->
            columns <- Array.append [| c |] columns ;
            0
        | Some p when p < len ->
            let a = Array.make (len+1) c in
            Array.blit columns 0 a 0 p;
            Array.blit columns (p+1) a (p+1) (len - p);
            columns <- a;
            p
        | _ ->
            columns <- Array.append columns [| c |] ;
            len
      in
      c#set_on_header_activated (Some (fun () -> self#on_header_activated c));
      c#set_list (Array.to_list data);
      min_width <- None ;
      min_height <- None ;
      if not frozen then self#resize_all ~need_resize:true ~from:pos ();
      pos

    method column_by_index n =
      if n < 0 || n >= Array.length columns
      then None
      else Some columns.(n)

    method private column_index c =
      let len = Array.length columns in
      let id = c#id in
      let rec iter i =
        if i >= len then
          None
        else
          if columns.(i)#id = id then
            Some i
          else
            iter (i+1)
      in
      iter 0

    method remove_column (c: 'a column) =
      match self#column_index c with
      | None -> Log.warn (fun m -> m "Column %s is not in %s" c#me self#me)
      | Some i ->
          columns <- array_remove columns i ;
          self#resize_all ~need_resize:true ()

    method private headers_height =
      match self#show_headers with
      | false -> 0
      | true ->
          Array.fold_left
            (fun acc c ->
               match c#header with
               | None -> acc
               | Some h -> max acc h#min_height)
            0 columns

    method private row_min_height i =
      Array.fold_left (fun acc col ->
         let cell = col#cell i in
         let min_h = cell#min_height in
         let h = match (cell#as_widget :> Widget.widget)#opt_p Props.max_height with
           | Some h when h >= 0 -> min min_h h
           | _ -> min_h
         in
         max acc h) 0 columns

    method private min_homogeneous_row_height =
      let max_row_h = ref 0 in
      Array.iteri (fun i _ ->
         max_row_h := max !max_row_h (self#row_min_height i)
      ) data;
      !max_row_h

    method! private min_width_ = Array.fold_left
      (fun acc c -> acc + c#min_width)
        ((max 0 (Array.length columns - 1)) * self#column_separator_width)
        columns

    method! private min_height_ =
      super#min_height_ +
        self#headers_height +
        ((max 0 (Array.length data - 1)) * self#line_separator_width) +
        match self#row_height with
        | n when n < 0 ->
            let acc = ref 0 in
            Array.iteri (fun i _ ->
               acc := !acc + (self#row_min_height i)
            ) data;
            !acc
        | 0 -> self#min_homogeneous_row_height * (Array.length data);
        | n -> n * (Array.length data)

    method max_width = None
    method max_height = None

    method set_geometry geom =
      [%debug "%s#set_geometry %a" self#me G.pp geom];
      super#set_geometry geom ;
      self#set_columns_geometry;
      self#resize_all ()

    method render_separators rend ~offset:(x,y) rg =
      (* render line separators *)
      let sep_color = self#line_separator_color in
      let sep_width = self#line_separator_width in
      if Array.length columns <= 0 then
        ()
      else
        let c = columns.(0) in
        for i = 0 to Array.length data - 2 do
          let g = (c#cell i)#geometry in
          let r = { G.x = 0 ; w = g_inner.w ; y = g.y + g.h ; h = sep_width } in
          match G.inter r rg with
          | None -> ()
          | Some r ->
              let r = G.translate ~x ~y r in
              Render.fill_rect rend (Some r) sep_color
        done;
      (* render column separators *)
      let sep_color = self#column_separator_color in
      let sep_width = self#column_separator_width in
      for i = 0 to Array.length columns - 2 do
        let g = columns.(i)#geometry in
        let r = { g with x = g.x + g.w ; w = sep_width } in
        match G.inter r rg with
        | None -> ()
        | Some r ->
            let r = G.translate ~x ~y r in
            Render.fill_rect rend (Some r) sep_color
      done;

    method render_me ~layer rend ~offset:(x,y) 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
      Array.iter (fun c -> c#render ~layer rend ~offset rg) columns;
      self#render_separators rend ~offset rg

    method private set_row_y_height i ~y ~h =
      Array.iter
        (fun col ->
           let c = col#cell i in
           let g = c#geometry in
           c#set_geometry { g with G.y ; h }
        )
        columns

    method private set_headers_heights =
      let h = self#headers_height in
      Array.iter
        (fun col ->
           match col#header with
           | None -> ()
           | Some hd ->
               let g = hd#geometry in
               hd#set_geometry { g with G.h }
        ) columns

    method private set_rows_heights ?(from=0) () =
      let len = Array.length data in
      let get_h =
        match self#row_height with
        | n when n < 0 -> (* every row has its own height *)
            self#row_min_height
        | 0 -> (* all rows have the same height *)
            let h = self#min_homogeneous_row_height in
            (fun _ -> h)
        | n -> (* all rows have the given height *)
            (fun _ -> n)
      in
      let sep_wid = self#line_separator_width in
      let rec iter i y =
        if i >= len then ()
        else
          (
           let h = get_h i in
           self#set_row_y_height i ~y ~h;
           iter (i+1) (y+h+sep_wid)
          )
      in
      let y =
        match from with
        | n when n <= 0 -> self#headers_height
        | n ->
            if Array.length columns = 0 then
              0
            else
              let col = columns.(0) in
              let g = (col#cell (n-1))#geometry in
              g.G.y + g.h
      in
      iter from y

(*    method private set_rows_sizes ?from () =*)

    method private resize_all ?(need_resize=false) ?(headers=true) ?from () =
      [%debug "%s#resize_all headers=%b" self#me headers];
      if headers then self#set_headers_heights ;
      if need_resize then self#need_resize;
        let from = match self#row_height with
          | 0 -> None
          | _ -> from
        in
        self#set_rows_heights ?from ()

    method! child_need_resize w =
      if not frozen then super#child_need_resize w

    method insert ?pos d =
      let len = Array.length data in
      Array.iter (fun col -> ignore(col#insert ?pos d)) columns ;
      let pos =
        match pos with
        | Some 0 ->
            data <- Array.append [| d |] data ;
            0
        | Some p when p < len ->
            let a = Array.make (len+1) d in
            Array.blit data 0 a 0 p;
            Array.blit data (p+1) a (p+1) (len - p);
            data <- a;
            p
        | _ ->
            data <- Array.append data [| d |] ;
            len
      in
      selection <- Misc.ISet.map
        (fun row -> if row >= pos then row + 1 else row)
        selection ;
      self#trigger_unit_event Row_inserted (pos, d);
      if not frozen then
        self#resize_all ~need_resize:true ~headers:false ~from:pos ();
      pos

    method remove row =
      if self#valid_row ~tip:"#remove" row then
        (
         Array.iter (fun col -> col#remove row) columns;
         selection <- Misc.ISet.fold
           (fun i acc ->
              if i = row then
                acc
              else
                let i = if i > row then i-1 else i in
                Misc.ISet.add i acc
           )
           selection Misc.ISet.empty;
         let removed = data.(row) in
         data <- array_remove data row ;
         self#trigger_unit_event Row_removed (row, removed);
         if not frozen then
           self#resize_all ~need_resize:true ~headers:false ~from:row ()
        )

    method set_row row d =
      if self#valid_row ~tip:"#set_row" row then
        (
         let prev = data.(row) in
         data.(row) <- d;
         Array.iter (fun col -> col#set_row row d) columns;
         self#trigger_unit_event Row_updated (row, prev, d) ;
         if not frozen then
           self#resize_all ~need_resize:true ~headers:false ~from:row ()
        )

    method set_list l =
      Array.iter (fun col -> col#set_list l) columns ;
      data <- Array.of_list l;
      selection <- Misc.ISet.empty ;
      self#trigger_unit_event Data_set l;
      if not frozen then self#resize_all ~need_resize:true ~headers:false ()

    method unfreeze =
      super#unfreeze ;
      self#resize_all ~need_resize:true ()

    method select_row ?(only=false) row =
      match self#selection_mode with
      | Props.Sel_none -> ()
      | sel_mode ->
          if self#valid_row ~tip:"#select_row" row then
            (
             if only || sel_mode <> Sel_multiple then
               Misc.ISet.iter self#unselect_row_ selection;
             let old_sel = selection in
             selection <- Misc.ISet.add row selection ;
             if not (Misc.ISet.equal old_sel selection) then
               (
                Array.iter (fun col -> ((col#cell row) :> Widget.widget)#set_selected true) columns;
                self#trigger_unit_event Row_selected (row, data.(row))
               )
            )
    method private unselect_row_ row =
      if self#valid_row ~tip:"#unselect_row" row then
        (
         let old_sel = selection in
         selection <- Misc.ISet.remove row selection;
         if not (Misc.ISet.equal old_sel selection) then
           (
            Array.iter (fun (col:'a column) -> (col#cell row)#set_selected false) columns;
            self#trigger_unit_event Row_unselected (row, data.(row))
           )
        )

    method unselect_row row =
      match self#selection_mode with
      | Sel_browse -> ()
      | _ -> self#unselect_row_ row

    method unselect_all =
      Misc.ISet.iter self#unselect_row_ selection

    method private select_or_unselect_row row =
      if Misc.ISet.mem row selection then
        if Key.is_mod_pressed Tsdl.Sdl.Kmod.ctrl then
          self#unselect_row row
        else
          ()
      else
        let only = not (Key.is_mod_pressed Tsdl.Sdl.Kmod.ctrl) in
        self#select_row ~only row

    method private on_button1_pressed (ev : Widget.button_ev) =
      let row = self#row_of_y ev.y in
      let col = self#col_of_x ev.x in
      let pp fmt = function
      | None -> Format.pp_print_string fmt "None"
      | Some n -> Format.pp_print_int fmt n
      in
      [%debug "%s#on_button1_pressed: row=%a, col=%a" self#me pp row pp col];
      match row, col with
      | Some row, Some _ ->
         self#select_or_unselect_row row;
         false
      | _, _ -> false

    method private on_button_pressed ev =
      match ev.Widget.button with
      | 1 -> self#on_button1_pressed ev
      | _ -> false

    method on_key_down pos (event:Sdl.event) key keymod =
      let open Tsdl.Sdl.K in
      match key with
      | k when k = up -> self#move_focus_up
      | k when k = down -> self#move_focus_down
      | k when k = left -> self#move_focus_left
      | k when k = right -> self#move_focus_right
      | k when k = home ->
          if Key.ctrl_pressed () then self#move_focus_home else self#move_focus_row_home
      | k when k = kend ->
          if Key.ctrl_pressed () then self#move_focus_end else self#move_focus_row_end
      | k when k = space ->
          (match self#focused_row with
           | None -> false
           | Some row -> self#select_or_unselect_row row; true
          )
      | _ -> super#on_key_down pos event key keymod

    method on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        match
          let f (x,y) = (x - g.x - g_inner.x , y - g.y - g_inner.y) in
          let oldpos = Option.map f oldpos in
          let pos = Option.map f pos in
          match Sdl.Event.(enum (get e typ)) with
          | `Key_down | `Key_up | `Text_input | `Text_editing ->
              (
               let pred w = (w:>Widget.widget)#get_p Props.is_focus in
               match array_find_opt pred columns with
               | None -> false
               | Some (_,w) -> w#on_sdl_event_down ~oldpos pos e
              )
          | _ ->
              let on_w w =
                let gw = w#geometry in
                if (match oldpos with
                   | Some (x,y) -> G.inside ~x ~y gw
                   | None -> false
                  ) ||
                  match pos with
                  | Some (x,y) -> G.inside ~x ~y gw
                  | None -> true
                then
                  (
                   (*Log.warn (fun m -> m "%s#on_sdl_event_down: propagating event to %s"
                      self#me w#me);*)
                   w#on_sdl_event_down ~oldpos pos e
                  )
                else
                  false
              in
              Array.fold_left
                (fun acc w -> on_w w || acc)
                false columns
        with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method sort_by_column ?(order=Ascending) c =
      match self#column_index c with
      | None -> ()
      | Some n -> self#set_sorted (n, order)

    method private focused_column =
      Option.map snd
        (array_find_opt
         (fun c -> (c:>Widget.widget)#get_p Props.is_focus)
           columns)
    method private focused_row = Option.map fst self#focused_cell
    method focused_cell =
      match self#focused_column with
      | None -> None
      | Some c ->
          match c#focused_child with
          | None -> None
          | Some (`Header _) -> None
          | Some (`Cell (j, _)) -> Some (j, c)

    method! focused_widget =
      if self#is_focus then
        match self#focused_column with
        | None -> Some self#coerce
        | Some w -> w#focused_widget
      else
        None
    method! release_focus =
      match
        match self#focused_column with
        | None -> true
        | Some c -> c#release_focus
      with
      | true ->
          self#set_p Props.is_focus false ;
          self#set_p Props.has_focus false ;
          true
      | _ -> false

    method! get_focus =
      match super#get_focus with
      | None -> None
      | Some has_focus ->
          Array.iter (fun w -> (w:>Widget.widget)#set_p Props.is_focus false) columns;
          Some has_focus

    method set_has_focus b =
      match super#set_has_focus b with
      | true -> true
      | false ->
          match self#focused_column with
          | None -> false
          | Some c -> c#set_has_focus b

    (* if a cell is focused, mak it grab the focus, else find the
       first cell able to grab the focus. *)
    method grab_focus ?(last=false) () =
      [%debug "%s#grab_focus ~last:%b" self#me last];
      if self#visible then
        match self#get_p Props.can_focus with
        | false -> false
        | true ->
            let b =
              match self#focused_column with
              | None -> false
              | Some c ->
                  match c#focused_child with
                  | None -> false
                  | Some (`Header w) -> w#grab_focus ~last ()
                  | Some (`Cell (_,w)) -> w#grab_focus ~last ()
            in
            match b with
            | true -> true
            | false ->
                let rec iter len i =
                  if i < 0 || i >= len then
                    false
                  else
                    let c = columns.(i) in
                    match c#visible, c#get_p Props.can_focus with
                    | true, true ->
                        (match c#grab_focus ~last () with
                         | false -> iter len (if last then i-1 else i+1)
                         | true -> true)
                    | _ -> iter len (if last then i-1 else i+1)
                in
                let len = Array.length columns in
                iter len (if last then len - 1 else 0)
      else
        false

    (* i is column index, j is row index *)
    method private try_focus_ij last i j =
      if j >= Array.length data then
        false
      else
        let col = columns.(i) in
        col#visible &&
          (let c = columns.(i)#cell j in
           c#grab_focus ~last ())

    method private debug_move_focus_fun f i j =
      Printf.sprintf "%s#move_focus_%s_ij i=%d j=%s"
        self#me f i
        (match j with None -> "None"
         | Some `Header -> "Header"
         | Some (`Cell j) -> Printf.sprintf "Cell %d" j)

    method private move_focus_next_ij i j =
      self#focus_next
(*      [%debug "%s" (self#debug_move_focus_fun "next" i j));
      match j with
      | None ->
          (match columns.(i)#header with
           | None -> self#move_focus_next_ij i (Some `Header)
           | Some w ->
               match w#grab_focus () with
               | true -> true
               | false -> self#move_focus_next_ij i (Some `Header)
          )
      | Some `Header when i + 1 < Array.length columns ->
          self#move_focus_next_ij (i+1) None
      | Some `Header -> (* last col *)
          self#try_focus_ij false 0 0
          || self#move_focus_next_ij 0 (Some (`Cell 0))
      | (Some (`Cell j)) as cj when i + 1 < Array.length columns ->
          (* not last col *)
          self#try_focus_ij false (i+1) j
            || self#move_focus_next_ij (i+1) cj
      | Some (`Cell j) when j+1 < Array.length data ->
          (* last col but not last row *)
          self#try_focus_ij false 0 (j+1)
            || self#move_focus_next_ij 0 (Some (`Cell (j+1)))
      | _ -> (* last col and last row *)
          self#focus_next
*)
    method private move_focus_prev_ij i j =
      self#focus_prev
(*
      [%debug "%s" (self#debug_move_focus_fun "prev" i j));
      match j with
      | None -> self#move_focus_prev_ij i (Some (`Cell (Array.length data)))
      | Some (`Cell 0) when i <= 0 ->  (* first col of first row, move to header *)
          let cols = Array.length columns in
          self#move_focus_prev_ij cols (Some `Header)
      | Some (`Cell j) when i <= 0 -> (* first col but not first row *)
          let prev_i = Array.length columns - 1 in
          self#try_focus_ij true prev_i (j-1)
            || self#move_focus_prev_ij prev_i (Some (`Cell (j-1)))
      | (Some (`Cell j)) as cj -> (* not first col *)
          self#try_focus_ij true (i-1) j
          || self#move_focus_prev_ij (i-1) cj
      | Some `Header when i <= 0 -> (* first col *)
          self#focus_prev
      | Some `Header -> (* not first col *)
          (match columns.(i-1)#header with
           | None -> self#move_focus_prev_ij (i-1) (Some `Header)
           | Some w ->
               match w#grab_focus () with
               | true -> true
               | false -> self#move_focus_prev_ij (i-1) (Some `Header)
          )
*)
    method private move_focus_up_ij i j =
      [%debug "%s" (self#debug_move_focus_fun "up" i j)];
      match j with
      | None -> false
      | Some `Header -> false
      | Some (`Cell 0) ->
          (match columns.(i)#header with
          | None -> false
          | Some w -> w#grab_focus ~last:true ())
      | Some (`Cell j) ->
          let j = j - 1 in
          if j >= 0 && j < Array.length data then
            self#try_focus_ij true i j
              || self#move_focus_up_ij i (Some (`Cell j))
          else
            false

    method private move_focus_down_ij i j =
      [%debug "%s" (self#debug_move_focus_fun "down" i j)];
      match j with
      | None -> false
      | Some `Header ->
          if Array.length data > 0 then
            self#try_focus_ij false i 0
              || self#move_focus_down_ij i (Some (`Cell 0))
          else
            false
      | Some (`Cell j) when j + 1 >= Array.length data ->
          false
      | Some (`Cell j) ->
          let j = j + 1 in
          if j + 1 > 0 then
            self#try_focus_ij false i j
              || self#move_focus_down_ij i (Some (`Cell j))
          else
            false

    method private move_focus_left_ij i j =
      [%debug "%s" (self#debug_move_focus_fun "left" i j)];
      match j with
      | None -> false
      | Some _ when i - 1 < 0 -> false
      | Some `Header ->
          let i = (min (Array.length columns) i) - 1 in
          (match columns.(i)#header with
           | None -> self#move_focus_left_ij i j
           | Some w ->
               w#grab_focus ~last:true ()
                 || self#move_focus_left_ij i j
          )
      | (Some (`Cell j)) as cj->
          let i = (min (Array.length columns) i) - 1 in
          if j < 0 || j >= Array.length data then
            false
          else
            self#try_focus_ij true i j
            || self#move_focus_left_ij i cj

    method private move_focus_right_ij i j =
      [%debug "%s" (self#debug_move_focus_fun "right" i j)];
      match j with
      | None -> false
      | Some _ when i + 1 >= Array.length columns -> false
      | Some `Header ->
          let i = max 0 (i+1) in
          (match columns.(i)#header with
           | None -> self#move_focus_right_ij i j
           | Some w ->
               w#grab_focus ()
                 || self#move_focus_right_ij i j
          )
      | (Some (`Cell j)) as cj ->
          let i = max 0 (i+1) in
          if j < 0 || j >= Array.length data then
            false
          else
            self#try_focus_ij false i j
            || self#move_focus_right_ij i cj

    method private move_focus_row_end_ij i j =
      [%debug "%s" (self#debug_move_focus_fun "row_end" i j)];
      let len = Array.length columns in
      match j with
      | None -> false
      | Some _ when len <= 0 || i >= Array.length columns -> false
      | Some `Header ->
          let i = len - 1 in
          (match columns.(i)#header with
           | None -> self#move_focus_left_ij i (Some `Header)
           | Some w ->
               w#grab_focus ()
               || self#move_focus_left_ij i (Some `Header)
          )
      | Some (`Cell j) ->
          if j < 0 || j >= Array.length data then
            false
          else
            let i = len - 1 in
            self#try_focus_ij true i j
              || self#move_focus_left_ij i (Some (`Cell j))

    method private move_focus_row_home_ij i j =
      [%debug "%s" (self#debug_move_focus_fun "row_home" i j)];
      let len = Array.length columns in
      match j with
      | None -> false
      | Some _ when len <= 0 || i = 0 -> false
      | Some `Header ->
          (match columns.(0)#header with
           | None -> self#move_focus_right_ij 0 (Some `Header)
           | Some w ->
               w#grab_focus ()
               || self#move_focus_right_ij 0 (Some `Header)
          )
      | Some (`Cell j) ->
          if j < 0 || j >= Array.length data then
            false
          else
            self#try_focus_ij true 0 j
              || self#move_focus_right_ij 0 (Some (`Cell j))

    method private move_focus direction (w:Widget.widget) =
      let id = w#id in
      match array_find_opt (fun c -> c#id = id) columns with
      | None ->
          (match direction with
           | `Backward -> self#focus_prev
           | `Forward -> self#focus_next
           | _ -> false
          )
      | Some (i,c) ->
          let set =
            match direction with
            | `Backward -> self#move_focus_prev_ij
            | `Forward -> self#move_focus_next_ij
            | `Up -> self#move_focus_up_ij
            | `Down -> self#move_focus_down_ij
            | `Left -> self#move_focus_left_ij
            | `Right -> self#move_focus_right_ij
            | `Row_end -> self#move_focus_row_end_ij
            | `Row_home -> self#move_focus_row_home_ij
          in
          match c#focused_child with
          | None -> set 0 None
          | Some (`Header _) -> set i (Some `Header)
          | Some (`Cell (j, _)) -> set i (Some (`Cell j))

    method! child_focus_next w = self#move_focus `Forward w
    method! child_focus_prev w = self#move_focus `Backward w
    method private focused_column_widget =
      match self#focused_column with
      | None -> None
      | Some c -> Some c#as_widget
    method move_focus_up =
      Option.fold ~none:false ~some:(self#move_focus `Up) self#focused_column_widget
    method move_focus_down =
      Option.fold ~none:false ~some:(self#move_focus `Down) self#focused_column_widget
    method move_focus_left =
      Option.fold ~none:false ~some:(self#move_focus `Left) self#focused_column_widget
    method move_focus_right =
      Option.fold ~none:false ~some:(self#move_focus `Right) self#focused_column_widget
    method move_focus_row_end =
      Option.fold ~none:false ~some:(self#move_focus `Row_end) self#focused_column_widget
    method move_focus_row_home =
      Option.fold ~none:false ~some:(self#move_focus `Row_home) self#focused_column_widget

    method move_focus_home =
      match self#focused_column with
      | Some c when Array.length data > 0 ->
          (
           match self#column_index c with
           | None -> false
           | Some i ->
               self#try_focus_ij false i 0
               || self#move_focus_down_ij i (Some (`Cell 0))
          )
      | _ -> false

    method move_focus_end =
      match self#focused_column with
      | Some c when Array.length data > 0 ->
          (
           match self#column_index c with
           | None -> false
           | Some i ->
               let j = Array.length data - 1 in
               self#try_focus_ij false i j
               || self#move_focus_up_ij i (Some (`Cell j))
          )
      | _ -> false

    method connect_row_removed (f: int -> 'a -> unit) =
      self#connect Row_removed (fun (n,d) -> f n d)
    method connect_row_inserted (f: int -> 'a -> unit) =
      self#connect Row_inserted (fun (n,d) -> f n d)
    method connect_data_set (f: 'a list -> unit) =
      self#connect Data_set f
    method connect_row_selected (f: int -> 'a -> unit) =
      self#connect Row_selected (fun (n,d) -> f n d)
    method connect_row_unselected (f: int -> 'a -> unit) =
      self#connect Row_unselected (fun (n,d) -> f n d)
    method connect_row_updated (f: int -> prev:'a -> now:'a -> unit) =
      self#connect Row_updated (fun (n,prev,now) -> f n ~prev ~now)

    method private on_sorted_changed ~prev ~now =
      let (i, order) = now in
      match self#column_by_index i with
      | None -> ()
      | Some c ->
          match c#sort_fun with
          | None -> ()
          | Some f ->
              let must_unfreeze =
                if not frozen then (self#freeze ; true) else false
              in
              (* unselect widgets of selected data *)
              let unsel_cols row (col:'a column) = (col#cell row)#set_selected false in
              let sel_cols row (col:'a column) = (col#cell row)#set_selected true in
              Misc.ISet.iter (fun row -> Array.iter (unsel_cols row) columns) selection;
              let sort = if order = Descending then (fun a b -> f b a) else f in
              let selected = List.sort sort self#selection_data in
              Array.sort sort data ;
              Array.iteri (fun i x -> self#set_row i x) data ;
              let len = Array.length data in
              let rec iter acc i selection =
                if i >= len then
                  acc
                else
                  match selection with
                  | [] -> acc
                  | x :: q ->
                      match sort x data.(i) with
                      | 0 ->
                          Array.iter (sel_cols i) columns;
                          iter (Misc.ISet.add i acc) (i+1) q
                      | n when n < 0 -> (* strange but we go forward in selection *)
                          iter acc i q
                      | _ ->
                          iter acc (i+1) selection
              in
              selection <- iter Misc.ISet.empty 0 selected;
              if must_unfreeze then self#unfreeze


    initializer
      ignore(self#connect Widget.Button_pressed self#on_button_pressed);
      ignore(self#connect (Object.Prop_changed row_height)
       (fun ~prev ~now -> self#resize_all ~need_resize:true ()));
      ignore(self#connect (Object.Prop_changed sorted) self#on_sorted_changed);
  end

let clist ?classes ?name ?props ?wdata ?pack ?selection_mode ?show_headers () =
  let w = new clist ?classes ?name ?props ?wdata () in
  Option.iter w#set_selection_mode selection_mode ;
  Option.iter w#set_show_headers show_headers ;
  Widget.may_pack ?pack w#coerce ;
  w