Source file dialog.ml

(** Dialog windows. *)

open Tsdl

class ['a] dialog ~class_ (on_return : unit -> unit) (window:Window.window)
  (content_area:Bin.bin) (action_area : unit Pack.box) =
  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 ?(class_=class_^"_button") ?return ?ks text =
        let (b,_) = Button.text_button ~class_
          ~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 =
        Lwt.async (fun () ->
           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 destroy = window#close
  end

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

let dialog ?(class_="dialog")
  ?(behaviour=`Destroy_on_return) ?flags ?rflags ?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 ~show:false ?x ?y ?w ?h title in
  let vbox = Pack.vbox ~class_ ~pack:w#set_child () in
  let c_area = Bin.bin ~class_:(class_^"_content_area")
    ~pack:(vbox#pack ~hexpand:1 ~vexpand:1) ()
  in
  let a_area = Pack.hbox ~class_:(class_^"_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 ~class_ on_return w c_area a_area in
  let _ = w#connect Window.Close
    (fun () ->
       let keep =
         Log.warn (fun m -> m "%s close event" w#me);
         match behaviour with
         | `Hide_on_return -> true
         | _ -> false
       in
       d#return None; keep)
  in
  d

let simple_input ?class_ ?behaviour ?flags ?rflags ?x ?y ?w ?h
  ?(ok="Ok") ?(cancel="Cancel") ?(orientation=Props.Horizontal) ?(msg="")
    ?(input=`Line) ?(text="") title =
  let d = dialog ?class_ ?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)