(***********************************************************************)

(*                                                                     *)

(*                 MLTk, Tcl/Tk interface of OCaml                     *)

(*                                                                     *)

(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)

(*               projet Cristal, INRIA Rocquencourt                    *)

(*            Jacques Garrigue, Kyoto University RIMS                  *)

(*                                                                     *)

(*  Copyright 2002 Institut National de Recherche en Informatique et   *)

(*  en Automatique and Kyoto University.  All rights reserved.         *)

(*  This file is distributed under the terms of the GNU Library        *)

(*  General Public License, with the special exception on linking      *)

(*  described in file LICENSE found in the OCaml source tree.          *)

(*                                                                     *)

(***********************************************************************)

open Camltk

(*

 * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple

 * jargon).

*)

let version = "$Id$"

(*

 * Simple requester

 *  an entry field, unrestricted, with emacs-like bindings

 * Note: grabs focus, thus always unique at one given moment, and we

 *  shouldn't have to worry about toplevel widget name.

 * We add a title widget in case the window manager does not decorate

 * toplevel windows.

*)

let open_simple title action notaction memory =

  let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in

  Focus.set t;

  Wm.title_set t title;

  let tit = Label.create t [Text title] in

  let len = max 40 (String.length (Textvariable.get memory)) in

  let e =

    Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in

  let activate _ =

    let v = Entry.get e in

     Grab.release t;                    (* because of wm *)

     destroy t;                         (* so action can call open_simple *)

     action v in

  bind e [[], KeyPressDetail "Return"] (BindSet ([], activate));

  let f = Frame.create t [] in

  let bok = Button.create f [Text "Ok"; Command activate] in

  let bcancel = Button.create f

            [Text "Cancel";

             Command (fun () -> notaction(); Grab.release t; destroy t)] in

    bind e [[], KeyPressDetail "Escape"]

         (BindSet ([], (fun _ -> Button.invoke bcancel)));

    pack [bok] [Side Side_Left; Expand true];

    pack [bcancel] [Side Side_Right; Expand true];

    pack [tit;e] [Fill Fill_X];

    pack [f] [Side Side_Bottom; Fill Fill_X];

    Frx_widget.resizeable t;

    Focus.set e;

    Tkwait.visibility t;

    Grab.set t

(* A synchronous version *)

let open_simple_synchronous title memory =

  let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in

  Focus.set t;

  Wm.title_set t title;

  let tit = Label.create t [Text title] in

  let len = max 40 (String.length (Textvariable.get memory)) in

  let e =

    Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in

  let waiting = Textvariable.create_temporary t in

  let activate _ =

     Grab.release t;                    (* because of wm *)

     destroy t;                         (* so action can call open_simple *)

     Textvariable.set waiting "1" in

  bind e [[], KeyPressDetail "Return"] (BindSet ([], activate));

  let f = Frame.create t [] in

  let bok = Button.create f [Text "Ok"; Command activate] in

  let bcancel =

     Button.create f

        [Text "Cancel";

         Command (fun () ->

                   Grab.release t; destroy t; Textvariable.set waiting "0")] in

    bind e [[], KeyPressDetail "Escape"]

         (BindSet ([], (fun _ -> Button.invoke bcancel)));

    pack [bok] [Side Side_Left; Expand true];

    pack [bcancel] [Side Side_Right; Expand true];

    pack [tit;e] [Fill Fill_X];

    pack [f] [Side Side_Bottom; Fill Fill_X];

    Frx_widget.resizeable t;

    Focus.set e;

    Tkwait.visibility t;

    Grab.set t;

    Tkwait.variable waiting;

    begin match Textvariable.get waiting with

      "1" -> true

    | _ -> false

    end

(*

 * Simple list requester

 * Same remarks as in open_simple.

 * focus seems to be in the listbox automatically

 *)

let open_list title elements action notaction =

  let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in

  Wm.title_set t title;

  let tit = Label.create t [Text title] in

  let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in

  let lb = Listbox.create fls [SelectMode Extended] in

  let sb = Scrollbar.create fls [] in

    Frx_listbox.scroll_link sb lb;

    Listbox.insert lb End elements;

  (* activation: we have to break() because we destroy the requester *)

  let activate _ =

    let l = List.map (Listbox.get lb) (Listbox.curselection lb) in

    Grab.release t;

    destroy t;

    List.iter action l;

    break() in

  bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate));

  Frx_listbox.add_completion lb activate;

  let f = Frame.create t [] in

  let bok = Button.create f [Text "Ok"; Command activate] in

  let bcancel = Button.create f

            [Text "Cancel";

             Command (fun () -> notaction(); Grab.release t; destroy t)] in

    pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true];

    pack [lb] [Side Side_Left; Fill Fill_Both; Expand true];

    pack [sb] [Side Side_Right; Fill Fill_Y];

    pack [tit] [Fill Fill_X];

    pack [fls] [Fill Fill_Both; Expand true];

    pack [f] [Side Side_Bottom; Fill Fill_X];

    Frx_widget.resizeable t;

    Tkwait.visibility t;

    Grab.set t

(* Synchronous *)

let open_passwd title =

  let username = ref ""

  and password = ref ""

  and cancelled = ref false in

  let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in

  Focus.set t;

  Wm.title_set t title;

  let tit = Label.create t [Text title]

  and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ())

  and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ())

  in

  let fb = Frame.create t [] in

   let bok = Button.create fb

              [Text "Ok"; Command (fun _ ->

                                    username := Entry.get eu;

                                    password := Entry.get ep;

                                    Grab.release t; (* because of wm *)

                                    destroy t)] (* will return from tkwait *)

   and bcancel = Button.create fb

              [Text "Cancel"; Command (fun _ ->

                                    cancelled := true;

                                    Grab.release t; (* because of wm *)

                                    destroy t)] (* will return from tkwait *)

  in

    Entry.configure ep [Show '*'];

    bind eu [[], KeyPressDetail "Return"]

      (BindSetBreakable ([], (fun _ -> Focus.set ep; break())));

    bind ep [[], KeyPressDetail "Return"]

      (BindSetBreakable ([], (fun _ -> Button.flash bok;

                                       Button.invoke bok;

                                       break())));

    pack [bok] [Side Side_Left; Expand true];

    pack [bcancel] [Side Side_Right; Expand true];

    pack [tit;fu;fp;fb] [Fill Fill_X];

    Tkwait.visibility t;

    Focus.set eu;

    Grab.set t;

    Tkwait.window t;

    if !cancelled then failwith "cancelled"

    else (!username, !password)