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

(** Widget base class. *)

open Misc
open Tsdl

[@@@landmark "auto"]

(** {2 Global keys}

Keys to make focus circulate between widgets:
*)

(** Keys to move focus to next widget. *)
let focus_next_keys = ref (Key.keystate Sdl.K.tab)

(** Keys to move focus to previous widget. *)
let focus_prev_keys = ref (Key.keystate ~mods:Sdl.Kmod.shift Sdl.K.tab)

(** {2 Widget tree}

This representation of widget tree is used for debugging.
*)

type 'a tree = N of 'a * 'a tree list
let rec pp_tree ppf ?(indent="") fmt = function
| N (x, l) ->
    Format.fprintf fmt "%s%a\n" indent ppf x;
    List.iter (pp_tree ppf ~indent:(indent^"  ") fmt) l

(** {2 Events} *)

(** Button event (press, release, click)
  holding the original SDL event and fields
  with the button and coordinates of mouse cursor in event. *)
type button_ev = {event:Sdl.event; button:int; x:int; y:int}

(** Mouse motion event holding the original SDL event and
  the coordinates of the mouse cursor in event. *)
type mouse_motion_ev = {event:Sdl.event; x:int; y:int}

(** Key event (press or release) with the origina SDL event,
  the concerned key and the activated modifiers. *)
type key_ev = {event:Sdl.event; key:Sdl.keycode; mods:Sdl.keymod }

(** Drop (filename or text) event, with mouse coordinates. *)
type drop_ev = { text: string ; x:int; y:int }

(** Events common to all widgets. Extend the {!Events.type-ev} type
  so that callbacks can be registered to be called when a widget
  triggers an event.
*)
type _ Events.ev +=
| Clicked : (button_ev -> bool) Events.ev (** A click occured in widget (press and release button). *)
| Activated : (unit -> unit) Events.ev (** The widget was activated, like a menu item or a button. *)
| Button_pressed : (button_ev -> bool) Events.ev (** A button was pressed in widget. *)
| Button_released : (button_ev -> bool) Events.ev (** A button was released in widget. *)
| Key_pressed : (key_ev -> bool) Events.ev (** A key was pressed in a focused widget. *)
| Key_released : (key_ev -> bool) Events.ev (** A key was released in a focused widget. *)
| Mouse_enter : (unit -> bool) Events.ev (** Mouse cursor entered the widget. *)
| Mouse_leave : (unit -> bool) Events.ev  (** Mouse cursor leaved the widget. *)
| Mouse_motion : (mouse_motion_ev -> bool) Events.ev (** Mouse moved over the widget. *)
| Destroy : (unit -> bool) Events.ev (** Widget is being destroyed. *)
| Geometry_changed : (unit -> unit) Events.ev (** Geometry of widget changed. *)
| File_dropped : (drop_ev -> bool) Events.ev (** A file is drag'n'dropped on widget *)
| Text_dropped : (drop_ev -> bool) Events.ev (** Text is drag'n'dropped on widget *)

(** {2 Widget types} *)

(** This extensible type is used to add constructor for each widget. The {!class-widget}
  has a method [typ] returning an optional value of this type. When only values
  of class [widget] are available, this method can be used to retrieve the object
  corresponding to the widget type and use its specific methods.*)
type widget_type = ..

(** {2 Widget data} *)

(**
A widget can hold an optional value of the {!type-wdata} extensible type. This is useful
to store application-specific data directly in some widgets rather than storing
them in a map aside.
*)
type wdata = ..

(** {2 Expressing size constraints} *)

type size_constraints = {
    min: int (* min size *) ;
    max_used : int option (* max sized really used by widget *) ;
    max_abs : int option (* max sized the widget can display *) ;
  }

let size_constraints ?max_used ?max_abs min = { min ; max_used ; max_abs }
let size_constraints_none = size_constraints 0
let size_constraints_fixed s = { min = s ; max_used = Some s ; max_abs = Some s }

let pp_size_constraints =
  let nopt = function None -> "None" | Some n -> string_of_int n in
  fun ppf c ->
    Format.fprintf ppf "{min=%d; max_used=%s; max_abs=%s}"
      c.min (nopt c.max_used) (nopt c.max_abs)

let add_to_size_constraints c n =
  { min = c.min + n ;
    max_used = Option.map ((+) n) c.max_used ;
    max_abs = Option.map ((+) n) c.max_abs ;
  }

let size_constraints_max =
  let m v1 v2 =
    match v1, v2 with
    | None, _ | _, None -> None
    | Some v1, Some v2 -> Some (max v1 v2)
  in
  fun c1 c2 ->
    { min = max c1.min c2.min ;
      max_used = m c1.max_used c2.max_used ;
      max_abs = m c1.max_abs c2.max_abs ;
    }

let size_constraints_add =
  let f w1 w2 =
    match w1, w2 with
    | None, _ | _, None -> None
    | Some w1, Some w2 -> Some (w1 + w2)
  in
  fun c1 c2 ->
    let min = c1.min + c2.min in
    let max_used = f c1.max_used c2.max_used in
    let max_abs = f c1.max_abs c2.max_abs in
    { min ; max_used ; max_abs }

(** {2 Widget class} *)

(** The base widget class. It contains methods to be called by children widgets,
  event if the base class does not handle child widgets.

  Setting and getting property values should be done by using [get_...] and
  [set_...] methods. When a property has no [set_...] method, it should not
  be modified from out of the class (but can be set by inheriting classes).
*)
class virtual widget ?(classes=[]) ?name ?props ?wdata () =
  let exp_props = props in
  object(self)
    inherit Object.o ?props () as super

    (**/**)

    val mutable classes = Sset.of_list (List.map String.lowercase_ascii classes)
    val mutable wdata = (wdata : wdata option)
    val mutable parent = (None : widget option)
    val mutable with_renderer = (None : ((Sdl.renderer -> unit Lwt.t) -> unit Lwt.t) option)
    val mutable theme_props : Theme.computed_props = Css.C.empty
    val explicit_props : Props.props = match exp_props with None -> Props.create() | Some p -> p

    val mutable width_constraints = None
    val mutable height_constraints = None

    val mutable typ : widget_type option = None
    method set_typ t = typ <- Some t

    (**/**)

    (** Widget type, if provided. *)
    method typ : widget_type option = typ

    (** Kind of the widget, used for theming and debug output. *)
    method virtual kind : string

    (** Classes, used for theming. *)
    method classes = classes

    method add_class str =
      if Sset.mem str classes then
        ()
      else
        (
         classes <- Sset.add str classes;
         self#apply_theme
        )

    method rem_class str =
      if Sset.mem str classes then
        (
         classes <- Sset.remove str classes;
         self#apply_theme
        )

    (** Name of the object, used for theming.*)
    method name = name

    (** A string representaton of the widget, with its kind and id. *)
    method! me = Printf.sprintf "[%s/%s]"
      (Option.value ~default:self#kind name) (Oid.to_string self#id)

    (** All widgets should have a [as_...] method to coerce to its
      own class.*)
    method as_widget = (self :> widget)

    (** [w#coerce] returns the widget coerced to [widget] type. *)
    method coerce = (self :> widget)

    (** Tree representation of widget and its children. *)
    method wtree : widget tree = N (self#coerce, [])

    (** Widget equality based on their unique {!Object.class-o.id}. *)
    method equal (w : widget) = Oid.equal self#id w#id

    (** Returns parent widget, is any. *)
    method parent = parent

    (** Get computed theme properties. *)
    method theme_props = theme_props

    (** Returns the top widget, going up through parent widgets until the
       one with no parent. *)
    method top_widget =
      match parent with
      | None -> self#coerce
      | Some p -> p#top_widget

    (** [w#top_window] returns the SDL window the widget is displayed in, if any. *)
    method top_window =
      match parent with
      | None -> (None : Sdl.window option)
      | Some w -> w#top_window

    (** {2 Widget data} *)

    method wdata = wdata
    method set_wdata d = wdata <- d

    (** {2 Geometry} *)

    (**/**)

    (* position in parent's texture *)
    val mutable g = G.zero

    (**/**)

    (** Geometry of widget, relative to its parent. *)
    method geometry = g

    (**/**)
    val mutable g_inner = G.zero

    (**/**)

    (** Inner geometry, relative to top-left corner of the widget.
      This is the rectangle used by widget after removing border widths
      and paddings from its allocated geometry. *)
    method g_inner = g_inner

    (** [w#desktop_coords ~x ~y] converts the given coordinates relative to
      widget top-left corner to desktop coordinates. *)
    method to_desktop_coords ~(x:int) ~(y:int) =
      match parent with
      | None -> (0, 0)
      | Some w -> w#to_desktop_coords ~x:(x+g.x+g_inner.x) ~y:(y+g.y+g_inner.y)

    (** [w#to_top_window_coords ~x ~y] converts the given coordinates relative to
      widget top-left corner to coordinates relative to top widget's top window. *)
    method to_top_window_coords ~(x:int) ~(y:int) =
      match parent with
      | None -> g_inner.x + x, g_inner.y + y
      | Some w ->
          (*let x0 = x and y0 = y in*)
          let (x, y) = w#to_top_window_coords ~x:(x+g.x+g_inner.x) ~y:(y+g.y+g_inner.y) in
          (*Log.warn (fun m -> m "%s#to_top_window_coords ~x:%d ~y:%d => %d, %d" self#me x0 y0 x y);*)
          (x, y)

    (** {2 Freezing and resizing} *)

    (**/**)

    val mutable frozen = false

    (**/**)

    (** A frozen widget will not ask for rendering (but can render). This
      is useful when a lot of computations are performed and each may
      require rendering. Freezing a widget will block rendering request
      from children widgets, until all is ready. They unfreezing the
      widget will ask for its rendering.
    *)

    method freeze = frozen <- true
    method unfreeze = frozen <- false

    (**/**)

    val mutable ignore_need_resize = false

    (**/**)

    (** A widget may require a resizing, i.e. ask its parent to compute its
        allocated geometry, typically because its size constraints changed.
        A widget can ignore its own requests for resizing or the ones from
        its children, for example when doing some updates that will need
        many resizings it is more performant to do one resizing when everything
        is computed. The {!Flex.class-flex} widget uses this. *)

    (** Ignore requests for resizing. *)
    method ignore_need_resize = ignore_need_resize <- true

    (** Do not ignore requests for resizing. *)
    method handle_need_resize = ignore_need_resize <- false

    method ignore_need_resize_do (f:unit -> unit) =
      let old = ignore_need_resize in
      try f () ;
        if not old then self#handle_need_resize
      with e ->
          if not old then self#handle_need_resize ;
          raise e

    (**/**)

    method cursor = (None : Sdl.cursor option)

    method! set_p : 'a. 'a Props.prop -> ?delay:float -> ?propagate:bool -> 'a -> unit =
      fun p ?delay ?propagate v ->
        Props.set explicit_props p v;
        super#set_p p ?delay ?propagate v ;
        match delay, Props.transition p with
        | Some _, Some _ -> ()
        | _ ->
            List.iter
              (function
               | Props.Render -> self#need_render g
               | Resize ->
                   self#need_resize;
                   self#need_render g
               | Action f -> f v
              )
              (Props.after p)
    (**/**)

    (** {2 Properties} *)

    method selected = self#get_p Props.selected
    method set_selected = self#set_p Props.selected
    (** A {!Props.val-selected} widget will render differently, using different
       background and foreground colors. *)

    method fill = self#get_p Props.fill
    method set_fill = self#set_p Props.fill
    (** {!Props.val-fill} property. *)

    method font = Props.get_font props
    (** Get the SDL font from the widget properties. *)

    method bg_fill_borders = self#get_p Props.bg_fill_borders
    method set_bg_fill_borders = self#set_p Props.bg_fill_borders
    (** {!Props.val-bg_fill_borders} property. *)

    method bg_color = self#get_p Props.bg_color
    method set_bg_color = self#set_p Props.bg_color
    (** {!Props.val-bg_color} property. *)

    method bg_color_selected = self#get_p Props.bg_color_selected
    method set_bg_color_selected = self#set_p Props.bg_color_selected
    (** {!Props.val-bg_color_selected} property. *)

    method bg_color_focused = self#get_p Props.bg_color_focused
    method set_bg_color_focused = self#set_p Props.bg_color_focused
    (** {!Props.val-bg_color_focused} property. *)

    method bg_color_hover = self#get_p Props.bg_color_hover
    method set_bg_color_hover = self#set_p Props.bg_color_hover
    (** {!Props.val-bg_color_hover} property. *)

    method fg_color = self#get_p Props.fg_color
    method set_fg_color = self#set_p Props.fg_color
    (** {!Props.val-fg_color} property. *)

    method fg_color_selected = self#get_p Props.fg_color_selected
    method set_fg_color_selected = self#set_p Props.fg_color_selected
    (** {!Props.val-fg_color_selected} property. *)

    method fg_color_focused = self#get_p Props.fg_color_focused
    method set_fg_color_focused = self#set_p Props.fg_color_focused
    (** {!Props.val-fg_color_focused} property. *)

    method fg_color_hover = self#get_p Props.fg_color_hover
    method set_fg_color_hover = self#set_p Props.fg_color_hover
    (** {!Props.val-fg_color_hover} property. *)

    method sensitive = self#get_p Props.sensitive
    method set_sensitive b = self#set_p Props.sensitive b
    (** {!Props.val-sensitive} property. *)

    method focusable = self#get_p Props.focusable
    method set_focusable = self#set_p Props.focusable
    (** {!Props.val-focusable} property. *)

    method can_focus = self#get_p Props.can_focus
    method set_can_focus = self#set_p Props.can_focus
    (** {!Props.val-can_focus} property. *)

    method show_on_focus = self#get_p Props.show_on_focus
    method set_show_on_focus = self#set_p Props.show_on_focus
    (** {!Props.val-show_on_focus} property. *)

    method padding = self#get_p Props.padding
    method set_padding = self#set_p Props.padding
    method set_padding_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.padding (Props.trbl ~top ~right ~bottom ~left)
    method set_padding__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.padding (Props.trbl__ x)
    (** {!Props.val-padding} property. *)

    method margin = self#get_p Props.margin
    method set_margin = self#set_p Props.margin
    method set_margin_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.margin (Props.trbl ~top ~right ~bottom ~left)
    method set_margin__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.margin (Props.trbl__ x)
    (** {!Props.val-margin} property. *)

    (** [w#hmargin] returns horizontal margins as [(left margin, right margin)]. *)
    method hmargin = let m = self#margin in m.left, m.right

    (** [w#vmargin] returns vertical margins as [(top margin, bottom margin)]. *)
    method vmargin = let m = self#margin in m.top, m.bottom

    method border_width = self#get_p Props.border_width
    method set_border_width = self#set_p Props.border_width
    method set_border_width_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.border_width (Props.trbl ~top ~right ~bottom ~left)
    method set_border_width__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.border_width (Props.trbl__ x)
    (** {!Props.val-border_width} property. *)

    method border_color = self#get_p Props.border_color
    method set_border_color = self#set_p Props.border_color
    method set_border_color_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.border_color (Props.trbl ~top ~right ~bottom ~left)
    method set_border_color__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.border_color (Props.trbl__ x)
    (** {!Props.val-border_color} property. *)

    method border_color_selected = self#get_p Props.border_color_selected
    method set_border_color_selected = self#set_p Props.border_color_selected
    method set_border_color_selected_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.border_color_selected (Props.trbl ~top ~right ~bottom ~left)
    method set_border_color_selected__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.border_color_selected (Props.trbl__ x)
    (** {!Props.val-border_color_selected} property. *)

    method border_color_focused = self#get_p Props.border_color_focused
    method set_border_color_focused = self#set_p Props.border_color_focused
    method set_border_color_focused_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.border_color_focused (Props.trbl ~top ~right ~bottom ~left)
    method set_border_color_focused__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.border_color_focused (Props.trbl__ x)
    (** {!Props.val-border_color_focused} property. *)

    method border_color_hover = self#get_p Props.border_color_hover
    method set_border_color_hover = self#set_p Props.border_color_hover
    method set_border_color_hover_ ?delay ?propagate top right bottom left =
      self#set_p ?delay ?propagate Props.border_color_hover (Props.trbl ~top ~right ~bottom ~left)
    method set_border_color_hover__ ?delay ?propagate x =
      self#set_p ?delay ?propagate Props.border_color_hover (Props.trbl__ x)
    (** {!Props.val-border_color_hover} property. *)

    method hexpand = self#get_p Props.hexpand
    method set_hexpand = self#set_p Props.hexpand
    (** {!Props.val-hexpand} property. *)

    method vexpand = self#get_p Props.vexpand
    method set_vexpand = self#set_p Props.vexpand
    (** {!Props.val-vexpand} property. *)

    method hfill = self#get_p Props.hfill
    method set_hfill = self#set_p Props.hfill
    (** {!Props.val-hfill} property. *)

    method vfill = self#get_p Props.vfill
    method set_vfill = self#set_p Props.vfill
    (** {!Props.val-vfill} property. *)

    method text_valign = self#get_p Props.text_valign
    method set_text_valign = self#set_p Props.text_valign
    (** {!Props.val-text_valign} property. *)

    method is_focus = self#get_p Props.is_focus
    (** {!Props.val-is_focus} property. *)

    method has_focus = self#get_p Props.has_focus
    (** {!Props.val-has_focus} property. *)

    method set_visible ?delay ?propagate b =
      [%debug "%s#set_visible %b" self#me b];
      self#set_p ?delay ?propagate Props.visible b
    method visible = self#get_p Props.visible
    (** {!Props.val-visible} property. *)

    method opacity = self#get_p Props.opacity
    method set_opacity = self#set_p Props.opacity

    (**/**)

    val mutable texture = (None : Texture.t option)
    val mutable valid_texture = true
    method destroy_texture = Option.iter Texture.destroy texture; texture <- None
    method invalidate_texture = valid_texture <- false
    method create_texture rend =
      match texture with
      | None ->
          if g_inner.w > 0 && g_inner.h > 0 then
            (
             let t = Texture.create rend ~w:g_inner.w ~h:g_inner.h in
             texture <- Some t;
             valid_texture <- true ;
             texture
            )
          else
            None
      | Some t -> Some t

    method texture : Sdl.renderer -> [`Exist of Texture.t | `New of Texture.t] option =
      fun rend ->
        match texture with
        | Some t ->
            if not valid_texture then
              (
               Texture.clear rend t ;
               valid_texture <- true ;
               Some (`New t)
              )
            else
              Some (`Exist t)
        | None ->
            match self#create_texture rend with
            | None -> None
            | Some t -> Some (`New t)


    method with_renderer = with_renderer
    method child_reparented (w:widget) = ()

    (**/**)

    (** {2 Showing (parts of) widget} *)

    (* This method asks that the widget to be in the renderer part of
       its parent. It can be used by viewport to scroll so that the widget
       is visible. *)
    method show =
      match parent with
      | None -> ()
      | Some p -> p#show_child_rect self#geometry

    (* This method asks that the given rect of the widget
       to be in the renderer part of its parent. It can be used
       by viewport to scroll so that the widget is visible.
    *)
    method show_rect r =
      match parent with
      | None -> ()
      | Some p -> p#show_child_rect r

    (* Make the given child rect appear in the rendered area, if it makes sense.
       Coordinates are relative to child coordinates.
     *)
    method show_child_rect (r:G.t) =
      [%debug "%s#show_child_rect %a" self#me G.pp r];
      let r = G.translate ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y) r in
      self#show_rect r

    (** Returns the visible rectangle of the widget. *)
    method visible_rect =
      match parent with
      | None -> g
      | Some p -> p#child_visible_rect self#as_widget

    (** Returns the visible rectangle of the given child widget. *)
    method child_visible_rect (w:widget) = (w#geometry:G.t)

    (** {2 Focus} *)

    (* Returns the widget with {!Props.val-is_focus} property set to [true].
       Containers will ask their children for the focused_widget. *)
    method focused_widget = if self#is_focus then Some self#coerce else None

    (* Ask the widget to release focus. Return [true] if ok. *)
    method release_focus =
      self#set_p Props.is_focus false ;
      self#set_p Props.has_focus false ;
      true

    (**/**)

    (* Ask for the focus, going up through containers until window.
       Return [None] if the focus is not given, [Some true] if
       the focus is given and the window has focus, [Some false]
       if the focus is given but the window does not have the focus. *)
    method get_focus =
      match self#get_p Props.can_focus with
      | false -> None
      | true ->
         match parent with
          | None -> None
          | Some p ->
              match p#get_focus with
              | None -> None
              | Some has_focus ->
                  self#set_p Props.is_focus true ;
                  [%debug "%s#get_focus has_focus=%b,@ Props.has_focus=%b,@ Props.focusable=%b"
                    self#me has_focus (self#get_p Props.has_focus) (self#get_p Props.focusable)];
                  if self#get_p Props.focusable then
                    (
                     self#set_p Props.has_focus has_focus ;
                     Some false
                    )
                  else
                    Some has_focus

    method set_has_focus b =
      match self#get_p Props.is_focus with
      | false -> false
      | true ->
          match self#get_p Props.focusable with
          | false -> false
          | true ->
              self#set_p Props.has_focus b ;
              if b && self#show_on_focus then self#show ;
              true

    (**/**)

    (** [w#grab_focus()] make widget [v] tries to grab focus. The widget
      must be visible and sensitive, with {!Props.can_focus} and {!Props.focusable}
      set to [true]. The [last] optional argument is used internally by
      some widgets containing various children.
      Returns [true] if the focus could be grabbed, else [false].
    *)
    method grab_focus ?(last=false) () =
      [%debug "%s#grab_focus ~last:%b" self#me last];
      if self#visible && self#sensitive then
        let can_focus = self#get_p Props.can_focus in
        let focusable = self#get_p Props.focusable in
        match can_focus && focusable with
        | false ->
            [%debug "%s#grab_focus: can_focus=%b, focusable=%b"
               self#me can_focus focusable];
            false
        | true ->
            match self#get_focus with
            | None -> false
            | Some _ -> true
      else
        false

    (**/**)

    method child_focus_next (w:widget) = self#focus_next

    (**/**)

    (** Give focus to next focusable widget. *)
    method focus_next =
      [%debug "%s(widget)#focus_next" self#me];
      match parent with
      | None -> false
      | Some p -> p#child_focus_next self#coerce

    (**/**)

    method child_focus_prev (w:widget) = self#focus_prev

    (**/**)

    (** Give focus to previous focusable widget. *)
    method focus_prev =
      [%debug "%s(widget)#focus_prev" self#me];
      match parent with
      | None -> false
      | Some p -> p#child_focus_prev self#coerce

    (**/**)

    method need_rendering geom =
      [%debug
         "%s#need_rendering geom=%a, g=%a, visible=%b"
           self#me G.pp geom G.pp g self#visible];
      match self#visible with
      | false -> None
      | true -> G.inter g geom

    method render_bg rend ~offset:(x,y) geom =
      if match self#opt_p Props.fill with
        | None -> false | Some b -> b
      then
        (
         let bg_rect =
           if self#bg_fill_borders then
             g
           else
             G.remove_border g (self#border_width)
         in
         match G.inter bg_rect geom with
         | None -> ()
         | Some rg ->
             let rect = G.translate ~x ~y rg in
             [%debug "%s#render_bg rg=%a, rect=%a" self#me G.pp rg G.pp rect];
             Render.fill_rect rend (Some rect) self#bg_color_now
        )

    method render_border rend ~offset geom =
      let b = self#get_p Props.border_width in
      let c = self#border_color_now in
      match self#need_rendering geom with
      | None -> ()
      | Some rg -> Render.render_borders rend ~offset ~g rg b c

    method render_insensitive rend ~offset:(x,y) rg =
      let color = self#get_p Props.insensitive_color_mask in
      let rect = G.translate ~x ~y rg in
      Render.fill_rect rend (Some rect) color

    method render_me rend ~offset rg = ()

    method render (rend:Sdl.renderer) ~offset (geom:G.t) =
      [%debug
         "%s#render ~offset=%d,%d geom=%a, g=%a, g_inner=%a"
           self#me (fst offset) (snd offset)
            G.pp geom G.pp g G.pp g_inner];
      if self#visible then
        (
         match self#need_rendering geom with
         | None -> ()
         | Some rg ->
             let target, offset =
               match self#opt_p Props.opacity with
               | Some opa when opa < 1. && rg.w > 0 && rg.h > 0 ->
                   (
                    (* create an intermediate texture to render to *)
                    let format = Sdl.Pixel.format_rgba8888 in
                    let access = Sdl.Texture.access_target in
                    let> t = Sdl.create_texture rend format access ~w:rg.w ~h:rg.h in
                    let opa = min 255 (max 0 (truncate (opa *. 255.))) in
                    Sdl.set_texture_blend_mode t Sdl.Blend.mode_blend ;
                    let> () = Sdl.set_texture_alpha_mod t opa in
                    let> alpha = Sdl.get_texture_alpha_mod t in
                    [%debug "%s: Setting opacity to %d (%s), alpha = %d\nrg=%a offset=%d,%d"
                         self#me opa (Color.to_string (Int32.of_int opa)) alpha
                         G.pp rg (fst offset) (snd offset)
                    ];
                    let old = Sdl.get_render_target rend in
                    let> () = Sdl.set_render_target rend (Some t) in
                    (Some (old, t, offset), (-rg.x, -rg.y))
                   )
               | _ -> (None, offset)
             in
             self#render_bg rend ~offset rg ;
             self#render_border rend ~offset rg ;
             self#render_me rend ~offset rg;
             if not self#sensitive then
               self#render_insensitive rend ~offset rg;
             match target with
             | None -> ()
             | Some (old_target, t, offset) ->
                 let (x,y) = offset in
                 let x = x + rg.x in
                 let y = y + rg.y in
                 let w = rg.w and h = rg.h in
                 let src = Sdl.Rect.create ~x:0 ~y:0 ~w ~h in
                 let dst = Sdl.Rect.create ~x ~y ~w ~h in
                 (*Log.warn (fun m -> m "%s render_copy src=%a dst=%a"
                    self#me G.pp_rect src G.pp_rect dst);*)
                 let> () = Sdl.set_render_target rend old_target in
                 let> () = Sdl.render_copy ~src ~dst rend t in
                 Sdl.destroy_texture t
        )

    method render_with_prepare (rend:Sdl.renderer) ~offset:(x,y) (geom:G.t) =
      [%debug
         "%s#render_with_prepare ?offset=%d,%d geom=%a, g=%a"
           self#me x y
            G.pp geom G.pp g];
      match self#need_rendering geom with
      | None -> ()
      | Some rg ->
          match self#prepare rend rg with
          | None -> ()
          | Some from ->
              (* texture is supposed to contain g_inner;
                 so g_inner.w is right bound of texture. Same for h. *)
              let src =
                let x = rg.x - g.x - g_inner.x in
                let y = rg.y - g.y - g_inner.y in
                { G.x ; y;
                  w = min (g_inner.w - x) rg.w ;
                  h = min (g_inner.h - y) rg.h ;
                }
              in
              let x = x + rg.x in
              let y = y + rg.y in
              let dst = { src with x ; y } in
              [%debug "%s#render_with_prepare Texture.render_copy src=%a, dst=%a, rg=%a"
                 self#me G.pp src G.pp dst G.pp rg];
              Texture.render_copy rend ~src ~dst from

    method prepare (rend:Sdl.renderer) (geom:G.t) = None

    method update_g_inner =
      let b = self#get_p Props.border_width in
      let p = self#get_p Props.padding in
      let x = max 0 (b.left + p.left) in
      let y = max 0 (b.top + p.top) in
      let w = max 0 (g.w - x - max 0 (p.right + b.right)) in
      let h = max 0 (g.h - y - max 0 (p.bottom + b.bottom)) in
      g_inner <- { x ; y ; w ; h }

    method set_geometry geom =
      [%debug "widget%s#set_geometry: %a"
         self#me G.pp geom];
      let old_g = g in
      g <- geom ;
      self#update_g_inner ;
      (*[%debug "%s#set_geometry: geom=%a, self#height_constraints.min=%d"
         self#me G.pp geom self#height_constraints.min];*)
      if g.w <> old_g.w || g.h <> old_g.h then self#destroy_texture ;
      if g <> old_g then self#trigger_unit_event Geometry_changed ();
      if g <> old_g && self#visible then
        (
         if G.has_intersect old_g g then
           (
            self#need_render (G.union old_g g)
           )
         else
           (
            self#need_render old_g;
            self#need_render g
           )
        )

    (**/**)

    (** {2 Theming} *)

    method css_atts = Smap.empty
    method css_path : ?parent_path:Theme.path -> unit -> Theme.path =
      fun ?parent_path () ->
        let p = match parent_path with
          | Some p -> p
          | None ->
              match parent with
              | None -> []
              | Some p -> p#css_path ?parent_path:None ()
        in
        let atts = Smap.add "class" (String.concat " " (Sset.elements classes)) self#css_atts in
        let atts = Smap.add "widget" "" atts in
        (self#kind,atts,name) :: p

    (** Properties of the widget, merged after applying theme.*)
    method private themable_props : Props.props Props.prop list = []

    method private do_apply_theme_more apply path inh = ()

    method do_apply_theme ~root ~parent parent_path rules =
      let path = self#css_path ~parent_path () in
      let inh = Css.C.filter_inherited parent in
      [%debug "%s#do_apply_theme path=%a\ninh=%a" self#me Theme.pp_path path Css.C.pp inh];
      let apply path ~root ~parent acc r =
        if List.exists (fun (s,_) -> Theme.selector_matches s path) r.Css.S.sel then
          (
           (*Log.warn (fun m -> m "rule match: %a" (Css.S.pp_rule_ snd) r);*)
           try
             let t = Css.compute_decls (module Theme.P) ~root ~parent acc r.decls in
             (*Log.warn (fun m -> m "%s#apply path ~root ~parent => acc = %a" self#me Css.C.pp t);*)
             t
           with e ->
               Log.err (fun m -> m "%s#do_apply_theme: %s" self#me (Printexc.to_string e));
               acc
          )
        else
          acc
      in
      theme_props <- List.fold_left (apply path ~root ~parent) inh rules ;
      (*Log.warn(fun m -> m "%s#do_apply_theme initial_props = %a" self#me Props.pp props);
         Log.warn (fun m -> m "%s#do_apply_theme theme_props=%a" self#me Css.C.pp t);*)
      (*Log.warn (fun m -> m "%s#do_apply_theme explicit_props=%a" self#me Props.pp explicit_props);*)
      let cprops = Theme.to_props theme_props in
      let new_props = Props.merge cprops explicit_props in
      (*self#set_props new_props;*)
      Props.iter (fun prop v -> Props.set props prop v) new_props;
      (*Log.warn(fun m -> m "%s#do_apply_theme => %a" self#me Props.pp props);*)
      let inh = Css.C.filter_inherited theme_props in
      (*Log.warn (fun m -> m "%s#do_apply_theme inh(theme_props)=%a" self#me Css.C.pp inh);*)
      List.iter (fun p ->
         (*Log.warn (fun m -> m "%s theming property %S" self#me (Props.name p));*)
         let props = Props.dup (self#get_p p) in
         (*Log.warn(fun m -> m "%s's initial %s = %a" self#me (Props.name p) Props.pp props);*)
         let name = Props.name p in
         let path = (name, Smap.empty, None) :: path in
         let t = List.fold_left (apply path ~root ~parent) inh rules in
         let cprops = Theme.to_props t in
         (* here theme definitions are preferred to initial props *)
         let new_props = Props.merge props cprops in
         (*Log.warn (fun m -> m "%s: property %s themed to %a" self#me (Props.name p)
            Props.pp new_props);*)
         self#set_p p new_props
      )
        self#themable_props;
      self#do_apply_theme_more
        (fun path inh ->
           let t = List.fold_left (apply path ~root ~parent) inh rules in
           Theme.to_props t)
        path inh;
      width_constraints <- None ;
      height_constraints <- None

     method apply_theme =
      match self#top_window with
      | None -> ()
      | Some _ ->
          let (root, parent, parent_path) =
            match parent with
            | None (* I am a window ! *) ->
                Css.C.empty, Css.C.empty, []
            | Some p ->
                self#top_widget#theme_props, p#theme_props,
                p#css_path ?parent_path:None ()
          in
          let rules = Theme.(rules (snd (current_theme ()))) in
          self#ignore_need_resize_do
            (fun () -> self#do_apply_theme ~root ~parent parent_path rules);
          (*self#need_resize*)

    (**/**)

    method set_parent ?with_rend w =
      [%debug "%s#set_parent %s" self#me
         (match w with None -> "NONE" | Some w -> w#me)];
      (if self#has_focus then ignore(self#focus_prev));
      self#destroy_texture ;
      with_renderer <- with_rend;
      parent <- w;
      self#apply_theme

    method to_g_inner_coords ~x ~y = (x - g.x - g_inner.x, y - g.y - g_inner.y)

    method private widget_min_width =
      let m = self#get_p Props.margin in
      let p = self#get_p Props.padding in
      let b = self#get_p Props.border_width in
      m.left + b.left + p.left + p.right + b.right + m.right

    method virtual private width_constraints_ : size_constraints

    method width_constraints =
      let c =
        match width_constraints with
        | Some c -> c
        | None ->
            let c = self#width_constraints_ in
            width_constraints <- Some c;
            c
      in
      if self#hexpand <= 0
      then { c with max_used = Some c.min }
      else c

    method private widget_min_height =
      let m = self#get_p Props.margin in
      let p = self#get_p Props.padding in
      let b = self#get_p Props.border_width in
      m.top + b.top + p.top + p.bottom + b.bottom + m.bottom

    method virtual private height_constraints_ : size_constraints

    method height_constraints =
      let c =
        match height_constraints with
        | Some c -> c
        | None ->
            let c = self#height_constraints_ in
            [%debug "%s#height_constraints: setting height_constraints to %a"
              self#me pp_size_constraints c];
            height_constraints <- Some c;
            c
      in
      if self#vexpand <= 0
      then { c with max_used = Some c.min }
      else c

    (* baseline from top, i.e. from g.x *)
    method baseline = g.h / 2

    (* need_render must be called with coordinates relative to
      the widget's parent (i.e. with same origin as g). *)
    method need_render (geom:G.t) =
      [%debug "widget%s#need_render on %a" self#me G.pp geom];
      if not frozen then
        match parent with
        | None -> ()
        | Some p ->
            match self#need_rendering geom with
            | None -> ()
            | Some rg -> p#child_need_render rg

    (* child_need_render must be called with coordinates relative
       to this widget.*)
    method child_need_render (geom : G.t) =
      [%debug "widget%s#child_need_render on %a" self#me G.pp geom];
      if not frozen then
        self#need_render
          (G.translate ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y) geom)

    method need_resize =
      [%debug "%s[widget]#need_resize visible=%b, ignore_need_resize=%b"
        self#me self#visible ignore_need_resize];
      width_constraints <- None ;
      height_constraints <- None ;
      match parent with
      | Some p when self#visible && not ignore_need_resize ->
          p#child_need_resize self#coerce
      | Some _ | None -> ()

    method child_need_resize (w:widget) =
      [%debug "widget%s#child_need_resize %s" self#me w#me];
      self#need_resize

    val mutable button_pressed = None
    val mutable mouse_on_widget = false

    method set_button_pressed b =
      button_pressed <- b

    method on_mouse_leave = self#trigger_event Mouse_leave ()
    method on_mouse_enter = self#trigger_event Mouse_enter ()
    method on_mouse_motion (ev : mouse_motion_ev) = false
    method on_file_dropped (file : drop_ev) = false
    method on_text_dropped (text : drop_ev) = false

    method set_mouse_on_widget b =
      let old = mouse_on_widget in
      mouse_on_widget <- b ;
      match old, mouse_on_widget with
      | false, true -> self#on_mouse_enter
      | true, false -> self#on_mouse_leave
      | _ -> false

    method on_key_down pos (event:Sdl.event) key keymod =
      [%debug "%s(widget)#on_key_down has_focus=%b"
         self#me self#has_focus];
      if self#get_p Props.has_focus then
        if Key.match_keys !focus_next_keys key keymod then
          self#focus_next
        else if Key.match_keys !focus_prev_keys key keymod then
            self#focus_prev
          else
            false
      else
        false

    method on_key_up pos (event:Sdl.event) key keymod =
      false

    (** Return false when the event was not handled. *)
    method on_sdl_event : (int*int) option -> Sdl.event -> bool =
      fun pos (event:Sdl.event) ->
        if not self#visible then
          false
        else
          begin
            [%debug "%s#on_sdl_event : %a" self#me Fmts.pp_event event];
            match pos with
            | None ->
                begin
                  match Sdl.Event.(enum (get event typ)) with
                  | `Window_event ->
                      (match Sdl.Event.(window_event_enum (get event window_event_id)) with
                       | `Leave ->
                           let _ = self#set_mouse_on_widget false in
                           false
                       | _ ->
                           (* `Enter is not handled, since window#on_window_event
                              sets pos to Some(x,y) and this position is checked below *)
                           false
                      )
                  | `Key_down ->
                      let mods = Sdl.Event.(get event keyboard_keymod) in
                      let key = Sdl.Event.(get event keyboard_keycode) in
                      (
                       match self#trigger_event Key_pressed
                         { event ; key ; mods }
                       with
                       | false -> self#on_key_down pos event key mods
                       | true -> true
                      )
                  | `Key_up ->
                      let mods = Sdl.Event.(get event keyboard_keymod) in
                      let key = Sdl.Event.(get event keyboard_keycode) in
                      (match self#trigger_event Key_released
                         { event ; key ; mods }
                       with
                       | false -> self#on_key_up pos event key mods
                       | true -> true
                      )
                  | _ -> false
                end
            | Some (x,y) ->
                if G.inside ~x ~y self#geometry then
                  let button = Sdl.Event.(get event mouse_button_button) in
                  let _ = self#set_mouse_on_widget true in
                  match Sdl.Event.(enum (get event typ)) with
                  | `Drop_file ->
                      (match Sdl.Event.drop_file_file event with
                      | None -> false
                      | Some file ->
                           let ev = { text = file ; x ; y } in
                           match self#trigger_event File_dropped ev with
                           | true -> true
                           | false -> self#on_file_dropped ev
                      )
                  | `Drop_text ->
                      (match Sdl.Event.drop_file_file event with
                      | None -> false
                      | Some text ->
                           let ev = { text ; x ; y } in
                           match self#trigger_event Text_dropped ev with
                           | true -> true
                           | false -> self#on_text_dropped ev
                      )

                  | `Mouse_button_down ->
                      (
                       [%debug "button down on %s, focusable=%b"
                          self#me self#focusable];
                       let _ =
                         match self#get_p Props.focusable with
                         | true -> self#grab_focus ()
                         | _ -> false
                       in
                       match self#trigger_event Button_pressed
                         { event; button; x ; y }
                       with
                       | true -> true
                       | false ->
                           match button_pressed with
                           | Some b when b = button -> false
                           | _ ->
                               self#set_button_pressed (Some button);
                               false
                      )
                  | `Mouse_button_up ->
                     (
                       match self#trigger_event Button_released
                         { event ; button ; x ; y }
                       with
                       | true -> true
                       | false ->
                           let b =
                             match button_pressed with
                             | None -> false
                             | Some b0 when b0 <> button ->
                                 (* release a button different than the one pressed,
                                    do nothing *)
                                 false
                             | Some _ ->
                                 self#trigger_event Clicked
                                   { event; button; x ; y }
                           in
                           self#set_button_pressed None;
                           b
                      )
                  | `Mouse_motion ->
                      (
                       let (ev : mouse_motion_ev) = { event ; x ; y } in
                       match self#trigger_event Mouse_motion ev with
                       | true -> true
                       | false -> self#on_mouse_motion ev
                      )
                  | _ -> false
                else
                  (* a mouse event but not above us *)
                  (
                   let _ = self#set_mouse_on_widget false in
                   self#set_button_pressed None ;
                   false
                  )
          end

    method on_sdl_event_down ~(oldpos:(int*int)option) (pos:(int*int) option) (ev:Sdl.event) =
      if self#sensitive then self#on_sdl_event pos ev else false

    method destroy =
      [%debug "widget%s#destroy" self#me];
      let _ = self#trigger_event Destroy () in
      (match self#opt_p Props.is_focus with
       | Some true -> ignore(self#release_focus)
       | _ -> ()
      );
      self#destroy_texture ;
      super#destroy

    (**/**)

    (** {2 Misc} *)

    (**/**)

    val mutable hovering_callbacks = ([]:Events.callback_id list)
    val mutable handle_hovering = false

    (**/**)

    (** [w#set_handle_hovering b] sets handling hovering to [b]. Handling hovering
      means that mouse cursor motions are tracked to trigger
      [Mouse_enter] and [Mouse_leave] events. Default is to ignore hovering
      to avoid computations. It is used for some wigets, like menu item or buttons
      for which such a visual feedback is important. Mouse cursor hovering
      affect the background, foreground and border colors of a widget.
    *)
    method set_handle_hovering b =
      match b, hovering_callbacks with
      | false, [] -> ()
      | false, _ ->
          handle_hovering <- false;
          List.iter Events.unregister hovering_callbacks ;
          self#destroy_texture ;
          self#need_render g
      | true, _ :: _ -> ()
      | true, _ ->
          let cb ev =
            self#destroy_texture ;
            self#need_render g ;
            [%debug "hovering on %s: mouse in:%b"
               self#me mouse_on_widget];
            false
          in
          handle_hovering <- true;
          let idin = self#connect Mouse_enter cb in
          let idout = self#connect Mouse_leave cb in
          hovering_callbacks <- [idin ; idout]

    (** Current background color, depending on mouse hovering, {!Props.is_focus}
      and {!Props.selected} properties. *)
    method bg_color_now =
      let c =
        if mouse_on_widget && handle_hovering then
          match self#opt_p Props.bg_color_hover with
          | None -> self#bg_color
          | Some c -> c
        else
          match self#get_p Props.is_focus, self#opt_p Props.bg_color_focused with
          | true, Some c -> c
          | _ ->
              if self#selected then
                self#bg_color_selected
              else
                self#bg_color
      in
      [%debug "%s#bg_color = %a" self#me Color.pp c];
      c

    (** Current foreground color, depending on mouse hovering, {!Props.is_focus}
      and {!Props.selected} properties. *)
    method fg_color_now =
      if mouse_on_widget && handle_hovering then
        match self#opt_p Props.fg_color_hover with
        | None -> self#fg_color
        | Some c -> c
      else
        match self#get_p Props.is_focus, self#opt_p Props.fg_color_focused with
        | true, Some c -> c
        | _ ->
            if self#selected then
              self#fg_color_selected
            else
              self#fg_color

    (** Current border color, depending on mouse hovering, {!Props.is_focus}
      and {!Props.selected} properties. *)
    method border_color_now =
      if mouse_on_widget && handle_hovering then
        match self#opt_p Props.border_color_hover with
        | None -> self#border_color
        | Some c -> c
      else
        match self#get_p Props.is_focus, self#opt_p Props.border_color_focused with
          | true, Some c -> c
          | _ ->
            if self#selected then
              self#border_color_selected
            else
              self#border_color

    (** Create a png rendering this widget. The widget must have a top window,
        since the renderer of this window is used. *)
    method render_to_png ~file =
      match self#top_window with
      | None ->
          Log.warn (fun m -> m "%s#render_to_png: no top window" self#me)
      | Some w ->
          let> src = Sdl.get_window_surface w in
          let> dst =
            let z = Int32.zero in
            Sdl.create_rgb_surface ~w:g.w ~h:g.h ~depth:16 z z z z
          in
          let src_rect =
            let (x,y) = self#to_top_window_coords ~x:(-g_inner.x) ~y:(-g_inner.y) in
            G.to_rect { g with x ; y }
          in
          let dst_rect = G.to_rect { g with x = 0 ; y = 0 } in
          let> () = Sdl.blit_surface ~src (Some src_rect) ~dst (Some dst_rect) in
          let code = Tsdl_image.Image.save_png dst file in
          if code <> 0 then
            Log.err (fun m -> m "%s#render_to_png: error while saving png to %s" self#me file)


    (**/**)

    method init = ()

    method is_leaf_widget = true
    method leaf_widget_at ~x ~y =
      if G.inside g ~x ~y && self#is_leaf_widget then Some self#coerce else None
    method next_widget ?(inside:widget option) ~loop (pred:widget->bool) (_:widget option) =
      match parent, inside with
      | _, Some i when self#equal i#coerce ->
          if loop then self#next_widget ?inside ~loop pred None else None
      | None, _ -> (None : widget option)
      | Some p, _ -> p#next_widget ?inside ~loop pred (Some self#coerce)
    method prev_widget ?(inside:widget option) ~loop (pred:widget->bool) (_:widget option) =
      match parent, inside with
      | _, Some i when self#equal i#coerce ->
          if loop then self#prev_widget ?inside ~loop pred None else None
      | None, _ -> (None : widget option)
      | Some p, _ -> p#prev_widget ?inside ~loop pred (Some self#coerce)

    method next_leaf_widget ?inside ~loop pred =
      self#next_widget ?inside ~loop (fun w -> w#is_leaf_widget && pred w)
    method prev_leaf_widget ?inside ~loop pred =
      self#prev_widget ?inside ~loop (fun w -> w#is_leaf_widget && pred w)

    initializer
      [%debug "%s created with props=%a" self#me
        Props.pp props];
  end

(** {3:widget_arguments Widget arguments}
  All widget classes handle the following optional arguments, which
  are handled by the convenient functions provided to create widgets
  (like {!Scrollbox.val-scrollbox}):
  {ul
  {- [classes] specifies the classes of the widget. This is used to
    retrieve its default properties when theming. Some widgets have
    default classes, some have classes depending on property values (like
    {!Props.val-orientation}.
  }
  {- [name] specifies the name of the widget. This is useful for
     debugging purposes and is also used in theming.
  }
  {- [props] specifies properties to use in addition to the default properties
     associated to kind, [classes] and [name] when theme is applied.
     Propertes [props] are merged with
     the default properties, with {!Props.merge}. This is useful to
     override or add some properties at widget creation.}
   }
   Convenient functions also handle a [pack] optional argument. It is
   a function called with the created widget coerced to {!class-widget} type,
   and is usually used to pack or add the created widget to another one.
*)

(** {2 Utils} *)

(** [pp_widget_tree ppf w] pretty-prints widget [w] and its children to formatter [ppf],
  with some properties. This is for debugging purpose. *)
let pp_widget_tree =
  let ppf fmt (w:widget) =
    Format.fprintf fmt "%s%s %a [g_inner=%a, padding=%s, margin=%s, visible=%b, is_focus=%b,  has_focus=%b fg_color=%a, font_desc=%a]"
      w#me
      (match w#classes with
       | set when Sset.is_empty set -> ""
       | set -> Printf.sprintf "[%s]" (String.concat ", " (Sset.elements set)))
      G.pp w#geometry
      G.pp w#g_inner
      Props.(prop_to_string padding w#padding)
      Props.(prop_to_string padding w#margin)
      w#visible (w#get_p Props.is_focus)
      (w#get_p Props.has_focus)
      Color.pp w#fg_color
      Font.pp_font_desc (w#get_p Props.font_desc)
  in
  fun fmt w -> pp_tree ppf fmt w

(** [pp ppf w] prints [w#me] to formater [ppf]. *)
let pp ppf w = Format.fprintf ppf "%s" w#me

(** [may_pack ?pack w] will apply the [pack] function if provided, to
  widget [w]. This is used by convenient functions, usually to pack
  a creatd widget, hence the name. *)
let may_pack ?pack (w:< coerce:widget; ..>) =
  match pack with
  | None -> ()
  | Some p -> p w#coerce

(**/**)
module TWidget = struct
    type t = widget
    let compare w1 w2 = Oid.compare w1#id w2#id
    let wrapper = None
    let transition = None
  end
module PWidget = Props.Add_prop_type (TWidget)
(**/**)

(** A function to create a property holding a widget. *)
let widget_prop = PWidget.mk_prop

class virtual oriented =
  object(self)
    method virtual add_class : string -> unit
    method virtual rem_class : string -> unit
    method virtual get_p : 'a. 'a Props.prop -> 'a
    method virtual set_p : 'a. 'a Props.prop -> ?delay:float -> ?propagate:bool -> 'a -> unit
    method orientation = self#get_p Props.orientation
    method set_orientation o =
      self#set_p Props.orientation o;
      match o with
      | Props.Vertical ->
          self#rem_class Props.(string_of_orientation Horizontal);
          self#add_class Props.(string_of_orientation Vertical)
      | Props.Horizontal ->
          self#rem_class Props.(string_of_orientation Vertical);
          self#add_class Props.(string_of_orientation Horizontal)
  end
(**/**)
module Ordered = struct
  type t = widget
  let compare w1 w2 = Oid.compare w1#id w2#id
  end
(**/**)

(** Set of widgets. *)
module Set = Set.Make(Ordered)

(** Map with widgets as keys. *)
module Map = Map.Make(Ordered)

(**/**)
exception Loop
let safe_pred pred =
  let acc = ref Set.empty in
  let pred w =
    if Set.mem w !acc then
      raise Loop
    else
       pred w
  in
  pred
let safe_next_widget ?inside ~loop pred w from =
  let pred = safe_pred pred in
  try w#next_widget ?inside ~loop pred from
  with Loop -> None
let safe_prev_widget ?inside ~loop pred w from =
  let pred = safe_pred pred in
  try w#prev_widget ?inside ~loop pred from
  with Loop -> None

let safe_next_leaf_widget ?inside ~loop pred w from =
  let pred = safe_pred pred in
  try w#next_leaf_widget ?inside ~loop pred from
  with Loop -> None
let safe_prev_leaf_widget ?inside ~loop pred w from =
  let pred = safe_pred pred in
  try w#prev_leaf_widget ?inside ~loop pred from
  with Loop -> None
(**/**)