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

(** Menus and menubars. *)

open Misc
open Widget
open Tsdl

(** A menu item with a menu attached can be either
  [Folded] or [Unfolded]. *)
type item_menu_state = Folded | Unfolded
let item_menu_state_wrapper =
    let to_string = function
  | Folded -> "folded" | Unfolded -> "unfolded"
  in
  let of_string = function
  | "folded" -> Folded
  | "unfolded" -> Unfolded
  | s -> Ocf.invalid_value (`String s)
  in
  Ocf.Wrapper.string_ to_string of_string

(**/**)
module TItem_menu_state = struct
    type t = item_menu_state
    let compare = Stdlib.compare
    let wrapper = Some item_menu_state_wrapper
    let transition = None
  end
module PItem_menu_state = Props.Add_prop_type(TItem_menu_state)
(**/**)

(** Property ["item_menu_state"] for menu state. Default is [Folded]. *)
let item_menu_state : item_menu_state Props.prop = PItem_menu_state.mk_prop
  ~default:Folded "item_menu_state"

(** Keyboard ["shortcut"] property for a menu. *)
let shortcut = Props.keystate_prop ~inherited:false "shortcut"

(** An entry in a menu. The child of the entry is displayed in
  the menu. A (sub)menu can be attached to the item. In this case,
  when the item is unfolded, its attached menu is displayed.
*)
class menuitem ?classes ?name ?props ?wdata () =
  object(self)
    inherit Bin.bin ?classes ?name ?props ?wdata () as super
    inherit Widget.oriented as oriented

    (** {2 Properties} *)

    (**/**)
    method kind = "menuitem"
    method set_orientation o =
      oriented#set_orientation o;
      let (exp_w, exp_h) =
        match o with
        | Horizontal -> 1, 0
        | Vertical -> 0, 1
      in
      Props.set props Props.hexpand exp_w ;
      Props.set props Props.vexpand exp_h
    (**/**)

    method shortcut = self#opt_p shortcut
    method set_shortcut = self#set_p shortcut

    (** {2 Submenu} *)

    (**/**)
    val mutable menu = (None: menu option)
    (**/**)

    method remove_menu =
      match menu with
      | None -> ()
      | Some _ -> menu <- None
    method set_menu m =
      self#remove_menu ;
      menu <- Some m;
      ignore((m:>widget)#connect Widget.Activated (self#on_menu_activated m))

    (**/**)
    method on_menu_activated (m:menu) () =
      match menu with
      (* keep menu in callback so that we can compare to current menu ;
         indeed, a menu could be associated to this item then
         removed and associated to another item. *)
      | Some menu when Oid.equal menu#id m#id ->
          self#trigger_unit_event Widget.Activated ()
      | _ -> ()

    method! wtree =
      let N (w,l) = super#wtree in
      let l = match menu with
        | None -> l
        | Some m -> l @ [m#wtree]
      in
      N (w, l)

    method! set_p : 'a. 'a Props.prop -> ?delay:float -> ?propagate:bool -> 'a -> unit =
      fun p ?delay ?(propagate=false) v ->
        super#set_p ?delay ~propagate p v ;
        match delay, Props.transition p with
        | Some _, Some _ -> ()
        | _ ->
            if propagate then
              match menu with
              | None -> ()
              | Some m -> (m:>widget)#set_p ~propagate p v
            else
              ()

    (**/**)

    (** {2 Actions} *)

    (** Activates the item. If no submenu is attached, triggers
      the the [Widget.Activated] event. *)
    method activate =
      [%debug "%s activated" self#me];
      self#set_selected true ;
      match menu with
      | None -> self#trigger_unit_event Widget.Activated ()
      | Some _ -> (*self#unfold*) ()

     (**/**)
     method private fold =
      match menu with
      | None ->
          [%debug "%s#unfold: no menu" self#me];
      | Some (menu:menu) ->
          [%debug "%s#unfold: closing menu %s" self#me menu#me];
          menu#close;
          Props.set props item_menu_state Folded

    method private popup_coords (m:menu) =
      let w = m#min_width in
      let h = m#min_height in
      let (x,x2,y,y2) =
        match self#orientation with
        | Vertical ->
            (-g_inner.x, -g_inner.x + g.w - w, -g_inner.y + g.h, -g_inner.y - h)
        | Horizontal ->
            (-g_inner.x + g.w, -g_inner.x - w, -g_inner.y, -g_inner.y + g.h - h)
      in
      let di =
        match self#top_window with
        | None ->
            Log.warn (fun m -> m "%s#top_window = None" self#me);
            0
        | Some w ->
            let> di = Sdl.get_window_display_index w in
            [%debug "%s display window index = %d" self#me di];
            di
      in
      let> r = Sdl.get_display_bounds di in
      let r = G.of_rect r in
      let (x, y) = self#to_desktop_coords ~x ~y in
      let (x2, y2) = self#to_desktop_coords ~x:x2 ~y:y2 in
      let x = if x + w <= r.x + r.w || x2 < 0 then x else x2 in
      let y = if y + h <= r.y + r.h || y2 < 0 then y else y2 in
      (x, y)

    method private unfold =
      [%debug "%s#unfold" self#me];
      match Props.get props item_menu_state with
      | Unfolded -> ()
      | Folded ->
          match menu with
          | None -> ()
          | Some (m:menu) ->
              let (x, y) = self#popup_coords m in
              [%debug "%s#unfold x=%d, y=%d" self#me x y];
              let on_close last =
                match parent with
                | None -> ()
                | Some p ->
                    [%debug "%s#unfold/on_close parent=%s, last=%b" self#me p#me last];
                    Props.set props item_menu_state Folded
              in
              Props.set props item_menu_state Unfolded ;
              m#popup ?x:(Some x) ?y:(Some y) ?on_close:(Some on_close) ()

    method private on_item_menu_state_changed ~prev ~now =
      match now with
      | Unfolded -> self#unfold
      | Folded -> self#fold

    method on_selected_changed ~prev ~now =
      match menu with
      | None -> ()
      | Some _ -> if now then self#unfold else self#fold

    method! destroy =
      let () = match menu with
        | None -> ()
        | Some m -> m#destroy
      in
      super#destroy

    method! set_parent ?with_rend w =
      super#set_parent ?with_rend w

    initializer
      self#set_orientation self#orientation ;
      let _id = self#connect (Object.Prop_changed item_menu_state)
        self#on_item_menu_state_changed
      in
      let _id = self#connect (Object.Prop_changed Props.selected)
        self#on_selected_changed
      in
      let _id = self#connect Widget.Button_released
        (fun b ->
           if b.Widget.button = 1 then
             let _ = self#activate in
             true
           else
             false)
      in
      let _id = self#connect Widget.Button_pressed
        (fun b ->
           if b.Widget.button = 1 then
             ((match menu with
               | None -> ()
               | Some _ -> self#unfold
              );
             false
             )
           else
             false)
      in
      ()
  end

(** Menu widget.

  A menu inherited from {!Pack.class-box} to arrange its items.
  Regular menus have vertical orientation (i.e. items are packed vertically,
  but horizontal orientation is supported.
*)
and menu ?classes ?name ?(orientation=Props.Vertical) ?props ?wdata () =
  object(self)
    inherit [menuitem * Events.callback_id] Pack.box ?classes ?name ?props ?wdata () as super
    (**/**)
    method kind = "menu"
    val mutable win = (None : Window.window option)
    (**/**)

    (** Close the menu window if it exists (i.e. if menu is displayed).
      This also closes windows attached to the submenus of its items.
    *)
    method close =
      match win with
      | None ->
          [%debug "%s#close: no win !" self#me];
      | Some w ->
          [%debug "%s#close" self#me];
          win <- None;
          w#close;
          List.iter
            (fun c -> c.Container.widget#set_selected false)
            children

    (** Create a new window to display the menu.
       Optional parameters:
       {ul
        {- [x] and [y] for top-left coordoninates of the window.
          Default is to use mouse position.}
        {- [on_close] specifies a function to be called when the
          menu is closed. Argument indicates if the menu is the last
          still displayed.}
       }*)
    method popup ?x ?y ?on_close () =
      self#close ;
      let on_close last =
        self#close ;
        match on_close with
        | None -> ()
        | Some f -> f last
      in
      let w = App.popup_menu ~on_close ?x ?y (self:>Widget.widget) in
      win <- Some w

    (**/**)
    method private selected_child =
      List.find_opt (fun c -> c.Container.widget#selected) self#children

    method on_item_activated mi () =
      mi#set_selected ?delay:None ?propagate:None false;
      self#trigger_unit_event Widget.Activated () ;
      self#close ;
(*      App.close_menu_windows ()*)

    method on_mouse_leave =
      (
       match self#selected_child with
       | None -> ()
       | Some c ->
           match c.widget#get_p item_menu_state with
             | Unfolded -> (* keep unfolded item selected *) ()
             | _ -> c.widget#set_selected false
      );
      super#on_mouse_leave

    method on_mouse_motion ev =
        match self#child_by_coords ~x:ev.x ~y:ev.y with
        | None -> super#on_mouse_motion ev
        | Some c ->
            if not c.widget#selected then
              (
               (match self#selected_child with
                | None -> ()
                | Some c -> c.widget#set_selected false
               );
               c.widget#set_selected true
              );
            super#on_mouse_motion ev

    (**/**)

    (** Menu items must be added using this method rather than (inherited) [#pack].
      [pos] can be used to specify the 0-based position of the item among
      items already present. Default is to insert after all existing items.
    *)
    method add_item : ?pos:int -> menuitem -> unit =
        fun ?pos mi ->
          let cb = mi#connect Widget.Activated (self#on_item_activated mi) in
          self#pack ?pos ~data:(mi,cb) mi#coerce ;
          mi#set_orientation
            (match orientation with
             | Props.Vertical -> Props.Horizontal
             | Horizontal -> Vertical);

    (** Same as {!class-menu.add_item} but insert item as last item.*)
    method append_item mi = self#add_item ?pos:None mi

    (** Same as {!class-menu.add_item} but insert item as first item.*)
    method prepend_item mi = self#add_item ~pos:0 mi

    (** Menu items must be removed using this method rather than (inherited) [#unpack].*)
    method remove_item : menuitem -> unit =
      fun mi ->
        match self#child_by_widget mi#coerce with
        | None -> ()
        | Some c ->
            self#unpack mi#coerce;
            match c.data with
            | None -> ()
            | Some (_, id) -> mi#disconnect id

    (** Removes all items. *)
    method clear_items = List.iter
      (fun c ->
         match c.Container.data with
         | None -> ()
         | Some (mi,_) -> self#remove_item mi)
        self#children


    initializer
      self#set_orientation orientation ;
      Props.set props
        (match self#orientation with
         | Horizontal -> Props.vexpand
         | Vertical -> Props.hexpand) 0;
  end

(** Menubar widget.

  This widget inherited from {!Pack.class-box}, with horizontal [orientation ]by
  default, but vertical orientation is supported.*)
class menubar ?classes ?name ?(orientation=Props.Horizontal) ?props ?wdata () =
  object(self)
    inherit [menuitem * Events.callback_id] Pack.box ?classes ?name ?props ?wdata () as super

      (**/**)
    method kind = "menubar"
    val mutable prev_focused_widget = None
    val mutable active = false
    method private take_focus =
      match self#get_focus with
      | None -> false
      | Some _ -> true

    method on_button_pressed ev =
      [%debug "menubar %s clicked (active=%b)" self#me active];
      if ev.button = 1 then
        match active with
        | false ->
            let w = self#top_widget in
            prev_focused_widget <- w#focused_widget;
            active <- true ;
            self#set_can_focus true;
            self#set_focusable true;
            let b = self#take_focus in
            [%debug "%s#on_button_pressed take_focus=>%b" self#me b];
            (match prev_focused_widget with
             | None -> Log.warn (fun m -> m "%s: did not stole focus (top_widget=%s)"
                    self#me w#me)
             | Some w -> [%debug "%s: stole focus from %s" self#me w#me]
            );
            (*if not b then prev_focused_widget <- None;*)
              true
        | true ->
            (* no need to do anything because with the window taking
               back the focus, the menu windows are destroyed; let's just
               set active to [false]. *)
            (*(match self#selected_child with
               | None -> [%debug
               (fun m -> m "%s#on_button_pressed: no selected child" self#me)
               | Some c -> c.Container.widget#set_selected false
               );*)
            self#set_inactive ;
            true
      else
        false

    method on_item_activated mi () =
      mi#set_selected ?delay:None ?propagate:None false;
      active <- false ;
      self#set_focusable false;
      match prev_focused_widget with
      | None -> ()
      | Some w ->
          prev_focused_widget <- None ;
          ignore(w#grab_focus ());

    method private selected_child =
      List.find_opt (fun c -> c.Container.widget#selected) self#children
    method! on_mouse_leave =
      (
       match self#selected_child with
         | None -> ()
       | Some c ->
           match c.widget#get_p item_menu_state with
           | Unfolded ->
               (* keep unfolded item selected if not a top menu *)
               ()
           | _ -> c.widget#set_selected false
      );
      super#on_mouse_leave
    method! on_mouse_motion ev =
      match active with
      | false -> (* with don't have focus, do nothing *)
          super#on_mouse_motion ev
      | true ->
          match self#child_by_coords ~x:ev.x ~y:ev.y with
          | None -> super#on_mouse_motion ev
          | Some c ->
              if not c.widget#selected then
                (
                 (* select child before unselected previous child,
                    or else desotry the menu window then creating
                    the new one will trigger a gained focus event
                    on the normal window, which will make us delete
                    all menu windows, including the new one. *)
                 let prev_select_child = self#selected_child in
                 c.widget#set_selected true;
                 match prev_select_child with
                 | None -> ()
                 | Some c -> c.widget#set_selected false
                );
              super#on_mouse_motion ev

     (**/**)

    (** Menu items must be added using this method rather than (inherited) [#pack].
        [pos] can be used to specify the 0-based position of the item among
        items already present. Default is to insert after all existing items.*)
    method add_item : ?pos:int -> menuitem -> unit =
      fun ?pos mi ->
        let cb = mi#connect Widget.Activated (self#on_item_activated mi) in
        self#pack ?pos ~data:(mi,cb) mi#coerce ;
        mi#set_orientation
          (match orientation with
           | Props.Vertical -> Props.Horizontal
           | Horizontal -> Vertical);

    (** Same as {!class-menubar.add_item} but insert item as last item.*)
    method append_item mi = self#add_item ?pos:None mi

    (** Same as {!class-menubar.add_item} but insert item as first item.*)
    method prepend_item mi = self#add_item ~pos:0 mi

    (** Menu items must be removed using this method rather than (inherited) [#unpack].*)
    method remove_item : menuitem -> unit = fun mi ->
        match self#child_by_widget mi#coerce with
        | None -> ()
        | Some c ->
            self#unpack mi#coerce;
              match c.data with
              | None -> ()
              | Some (_, id) -> mi#disconnect id

    (** Removes all items. *)
    method clear_items = List.iter
      (fun c ->
         match c.Container.data with
         | None -> ()
         | Some (mi,_) -> self#remove_item mi)
        self#children

    (**/**)
    method private set_inactive =
      active <- false;
      match self#selected_child with
      | None -> ()
      | Some c -> c.Container.widget#set_selected false

    method! release_focus =
      self#set_inactive ;
      super#release_focus

    initializer
      self#set_orientation orientation ;
      Props.set props
        (match self#orientation with
         | Horizontal -> Props.vexpand
         | Vertical -> Props.hexpand) 0;
      ignore(self#connect Widget.Button_pressed self#on_button_pressed)
  end


(** Convenient function to create a {!class-menubar}.
  Optional argument [orientation] defines vertical or horizontal
  orientation; default is [Horizontal].
  See {!Widget.widget_arguments} for other arguments. *)
let menubar ?classes ?name ?orientation ?props ?wdata ?pack () =
  let w = new menubar ?classes ?name ?orientation ?props ?wdata () in
  Widget.may_pack ?pack w ;
  w

(** Convenient function to create a {!class-menuitem}.
  Optional argument [shortcut] defines keyboard shortcut.
  See {!Widget.widget_arguments} for other arguments. *)
let menuitem ?classes ?name ?props ?wdata ?shortcut ?pack () =
  let w = new menuitem ?classes ?name ?props ?wdata () in
  Option.iter w#set_shortcut shortcut ;
  Option.iter (fun f -> f w) pack ;
  w

(**/**)
let shortcut_prop = shortcut
(**/**)

(** Convenient function to create a {!class-menuitem} with a
  horizontal {!Pack.class-box} child.
  Two label widgets are added to the box. The first one is the label
  of the item (with initial [text] if provided).
  Optional argument [shortcut] defines keyboard shortcut and it is
  displayed in the second label (which has class ["menuitem_shortcut"]).
  See {!Widget.widget_arguments} for other arguments.
  The function returns the menu item and the first label (the one
  for the menu item text).*)
let label_menuitem ?classes ?name ?props ?wdata ?text ?shortcut ?pack () =
  let mi = menuitem ?classes ?name ?props ?wdata ?shortcut ?pack () in
  let hbox = Pack.hbox ~pack:mi#set_child () in
  let lab = Text.label ~pack:hbox#pack ?text () in
  let shortcut_lab = Text.label ~classes:["menuitem_shortcut"] ~pack:(hbox#pack ~hexpand:0) () in
  shortcut_lab#set_visible false;
  Option.iter (fun ks ->
     shortcut_lab#set_visible true;
     shortcut_lab#set_text (Key.string_of_keystate ks))
    shortcut;
  let _ = mi#connect (Object.Prop_changed shortcut_prop)
    (fun ~prev ~now ->
       shortcut_lab#set_visible true;
       shortcut_lab#set_text (Key.string_of_keystate now))
  in
  hbox#set_bg_color Color.transparent;
  (mi, lab)

(** Convenient function to create a {!class-menu}.
  Optional argument [orientation] defines vertical or horizontal
  orientation; default is [Vertical].
  See {!Widget.widget_arguments} for other arguments. *)
let menu ?classes ?name ?props ?wdata ?pack () =
  let w = new menu ?classes ?name ?props ?wdata () in
  Option.iter (fun f -> f w) pack ;
  w

(** {2 Utilities for popup menus} *)

(** Menu entry description:
  {ul
   {- [`I (text, cb)] is a label item with [text], and [cb] is called
      when item is activated.}
   {- [`C (text, init, cb)] is a checkbox item with [text]; [init] indicates
      whether the box is checked and [cb] is called with state when
      item is activated.}
   {- [`R [(text1, init1, cb1) ; ...] ] is same as [`C] but describes
      a list of radiobuttons.}
   {- [`M (text, entries)] describes a submenu with [text] for
      the menu item and a list of entries.}
  }
*)
type menu_entry =
  [ `I of string * (unit -> unit)
  | `C of string * bool * (bool -> unit)
  | `R of (string * bool * (bool -> unit)) list
  | `M of string * menu_entry list ]

(**/**)
let fill_menu m entries =
  let rec iter m = function
  | [] -> ()
  | e :: q ->
      let () =
        match e with
        | `I (text, cb) ->
            let (mi,_) = label_menuitem ~text ~pack:m#append_item () in
            let _ = mi#connect Widget.Activated cb in
            ()
        | `C _ ->
            Log.warn (fun m -> m "`C menu entry not implemented yet")
        | `R _ ->
            Log.warn (fun m -> m "`R menu entry not implemented yet")
        | `M (text, entries) ->
            let (mi,_) = label_menuitem ~text ~pack:m#append_item () in
            let m = menu ~pack:mi#set_menu () in
            iter m entries
      in
      iter m q
  in
  iter m entries
(**/**)

(** [popup_menu_entries entries] create a menu according to the [entries]
  description and pops it up. The menu is closed when an item is activated
  (or an event occurs closing menu windows). This function is typically
  used for contextual menus. *)
let popup_menu_entries (entries : menu_entry list) =
  let menu = menu () in
  fill_menu menu entries;
  menu#popup ()