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

(** Dialog windows. *)

open Tsdl

class ['a] dialog ?classes (on_return : unit -> unit) (window:Window.window)
  (content_area:Bin.bin) (action_area : unit Pack.box) =
  let () = window#add_class "dialog" in
  object(self)
      val mutable wakener = (None : 'a option Lwt.u option)
      method window = window
      method content_area = content_area
      method action_area = action_area

      method return ?(with_on_return=true) v =
        (
         match wakener with
         | None -> ()
         | Some w ->
             Lwt.wakeup_later w v;
             wakener <- None
        );
        if with_on_return then on_return () else ()

      method add_text_button ?classes ?return ?ks text =
        let (b,_) = Button.text_button ?classes
          ~pack:(action_area#pack ~hexpand:0 ~hfill:false) ~text:text ()
        in
        let () =
          match return with
          | None -> ()
          | Some f ->
              let _ =
                b#connect Widget.Activated
                  (fun () ->
                     self#return (f ()) ;
                  )
              in
              ()
        in
        let () =
          match ks with
          | None -> ()
          | Some ks -> Wkey.add window#as_widget ks
              (fun () -> let _ = b#activate in ())
        in
        b

      method run (f : 'a option -> unit Lwt.t) =
        let (t,u) = Lwt.wait () in
        self#return ~with_on_return:false None;
        wakener <- Some u;
        window#show;
        let _ = window#grab_focus () in
        let%lwt v = t in
        f v

      method run_async f = Lwt.async (fun () -> self#run f)

      method destroy = window#close
  end

type behaviour = [`Destroy_on_return | `Hide_on_return | `Modal_for of Window.window]

let dialog ?classes
  ?(behaviour=`Destroy_on_return) ?flags ?rflags ?resizable ?x ?y ?w ?h title =
  let modal_for = match behaviour with
    | `Modal_for w -> Some w
    | _ -> None
  in
  let w = App.create_window ?modal_for ?flags ?rflags ?resizable ~show:false ?x ?y ?w ?h title in
  let vbox = Pack.vbox ?classes ~pack:w#set_child () in
  let c_area = Bin.bin ~classes:["content_area"]
    ~pack:(vbox#pack ~hexpand:1 ~vexpand:1) ()
  in
  let a_area = Pack.hbox ~classes:["action_area"]
    ~pack:(vbox#pack ~hexpand:1 ~vexpand:0) ()
  in
  let on_return () =
    match behaviour with
    | `Hide_on_return -> w#hide
    | `Destroy_on_return
    | `Modal_for _ -> w#close
  in
  let d = new dialog ?classes on_return w c_area a_area in
  let _ = w#connect Window.Close
    (fun () ->
       let keep =
         match behaviour with
         | `Hide_on_return -> true
         | _ -> false
       in
       d#return None; keep)
  in
  d

let simple_input ?classes ?behaviour ?flags ?rflags ?x ?y ?w ?h
  ?(ok="Ok") ?(cancel="Cancel") ?(orientation=Props.Horizontal) ?(msg="")
    ?(input=`Line) ?(text="") title =
  let d = dialog ?classes ?behaviour ?flags ?rflags ?x ?y ?w ?h title in
  let c_box = Pack.box ~orientation ~pack:d#content_area#set_child () in
  let _msg = Text.label ~pack:(c_box#pack ~hexpand:0 ~vexpand:0) ~text:msg () in
  let get_text =
    match input with
    | `Line ->
        let e = Edit.entry ~pack:c_box#pack ~text () in
        (fun () -> e#text ())
    | `Text ->
        let scr = Bin.scrollbox ~pack:c_box#pack () in
        let tv = Textview.textview ~pack:scr#set_child () in
        let () = tv#insert text in
        (fun () -> tv#text ())
  in
  let _bok = d#add_text_button
    ~return:(fun () -> let s = get_text () in Some s)
    ~ks:(Key.keystate Sdl.K.return) ok
  in
  let _bcancel = d#add_text_button
    ~return:(fun () -> None)
    ~ks:(Key.keystate Sdl.K.escape) cancel
  in
  (d, get_text)